;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          gentils.lisp
;;;; Purpose:       Main general utility functions for KMRCL package
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Apr 2000
;;;;
;;;; $Id: genutils.lisp,v 1.15 2003/02/07 14:21:55 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************


(in-package :kmrcl)
(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))

(defmacro let-when ((var test-form) &body body)
  `(let ((,var ,test-form))
      (when ,var ,@body)))
  
(defmacro let-if ((var test-form) if-true &optional if-false)
  `(let ((,var ,test-form))
      (if ,var ,if-true ,if-false)))

;; Anaphoric macros

(defmacro aif (test then &optional else)
  `(let ((it ,test))
     (if it ,then ,else)))

(defmacro awhen (test-form &body body)
  `(aif ,test-form
        (progn ,@body)))

(defmacro awhile (expr &body body)
  `(do ((it ,expr ,expr))
       ((not it))
     ,@body))

(defmacro aand (&rest args)
  (cond ((null args) t)
        ((null (cdr args)) (car args))
        (t `(aif ,(car args) (aand ,@(cdr args))))))

(defmacro acond (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
            (sym (gensym)))
        `(let ((,sym ,(car cl1)))
           (if ,sym
               (let ((it ,sym)) ,@(cdr cl1))
               (acond ,@(cdr clauses)))))))

(defmacro alambda (parms &body body)
  `(labels ((self ,parms ,@body))
     #'self))


(defmacro aif2 (test &optional then else)
  (let ((win (gensym)))
    `(multiple-value-bind (it ,win) ,test
       (if (or it ,win) ,then ,else))))

(defmacro awhen2 (test &body body)
  `(aif2 ,test
         (progn ,@body)))

(defmacro awhile2 (test &body body)
  (let ((flag (gensym)))
    `(let ((,flag t))
       (while ,flag
         (aif2 ,test
               (progn ,@body)
               (setq ,flag nil))))))

(defmacro acond2 (&rest clauses)
  (if (null clauses)
      nil
      (let ((cl1 (car clauses))
            (val (gensym))
            (win (gensym)))
        `(multiple-value-bind (,val ,win) ,(car cl1)
           (if (or ,val ,win)
               (let ((it ,val)) ,@(cdr cl1))
               (acond2 ,@(cdr clauses)))))))


;; Debugging 

(defmacro mac (expr)
"Expand a macro"
  `(pprint (macroexpand-1 ',expr)))

(defmacro print-form-and-results (form)
  `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))

(defun show (&optional (what :variables) (package *package*))
  (ecase what
    (:variables (show-variables package))
    (:functions (show-functions package))))

(defun show-variables (package)
  (do-symbols (s package)
    (multiple-value-bind (sym status)
	(find-symbol (symbol-name s) package)
      (when (and (or (eq status :external)
		     (eq status :internal))
		 (boundp sym))
	(format t "~&Symbol ~S~T -> ~S~%"
		sym
		(symbol-value sym))))))

(defun show-functions (package)
  (do-symbols (s package)
    (multiple-value-bind (sym status)
	(find-symbol (symbol-name s) package)
      (when (and (or (eq status :external)
		     (eq status :internal))
		 (fboundp sym))
	(format t "~&Function ~S~T -> ~S~%"
		sym
		(symbol-function sym))))))

#+allegro
(ff:def-foreign-call (memory-status-dump "memory_status_dump")
    ()
  :strings-convert t)


;; Ensure functions

(defmacro ensure-integer (obj)
  "Ensure object is an integer. If it is a string, then parse it"
  `(if (stringp ,obj)
      (parse-integer ,obj)
    ,obj))

;; Lists

(defun mklist (obj)
  "Make into list if atom"
  (if (listp obj) obj (list obj)))

(defun filter (fn lst)
  "Filter a list by function, eliminate elements where fn returns nil"
  (let ((acc nil))
    (dolist (x lst)
      (let ((val (funcall fn x)))
        (if val (push val acc))))
    (nreverse acc)))

(defun appendnew (l1 l2)
  "Append two lists, filtering out elem from second list that are already in first list"
  (dolist (elem l2)
    (unless (find elem l1)
      (setq l1 (append l1 (list elem)))))
  l1)

;; Functions

(defun memo-proc (fn)
  "Memoize results of call to fn, returns a closure with hash-table"
  (let ((cache (make-hash-table :test #'equal)))
    #'(lambda (&rest args)
        (multiple-value-bind (val foundp) (gethash args cache)
          (if foundp
              val
              (setf (gethash args cache) 
                    (apply fn args)))))))

(defun memoize (fn-name)
  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))

(defmacro defun-memo (fn args &body body)
  "Define a memoized function"
  `(memoize (defun ,fn ,args . ,body)))

(defmacro _f (op place &rest args)
  (multiple-value-bind (vars forms var set access) 
                       (get-setf-expansion place)
    `(let* (,@(mapcar #'list vars forms)
            (,(car var) (,op ,access ,@args)))
       ,set)))

(defun compose (&rest fns)
  (if fns
      (let ((fn1 (car (last fns)))
            (fns (butlast fns)))
        #'(lambda (&rest args)
            (reduce #'funcall fns 
                    :from-end t
                    :initial-value (apply fn1 args))))
      #'identity))

;;; Loop macros

(defmacro until (test &body body)
  `(do ()
       (,test)
     ,@body))

(defmacro while (test &body body)
  `(do ()
       ((not ,test))
     ,@body))

(defmacro for ((var start stop) &body body)
  (let ((gstop (gensym)))
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
       ,@body)))

(defmacro with-each-stream-line ((var stream) &body body)
  (let ((eof (gensym))
	(eof-value (gensym))
	(strm (gensym)))
    `(let ((,strm ,stream)
	   (,eof ',eof-value))
      (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
	  ((eql ,var ,eof))
	,@body))))

(defmacro with-each-file-line ((var file) &body body)
  (let ((stream (gensym)))
    `(with-open-file (,stream ,file :direction :input)
      (with-each-stream-line (,var ,stream)
	,@body))))

		
;;; Keyword functions

(defun remove-keyword (key arglist)
  (loop for sublist = arglist then rest until (null sublist)
	for (elt arg . rest) = sublist
	unless (eq key elt) append (list elt arg)))

(defun remove-keywords (key-names args)
  (loop for ( name val ) on args by #'cddr
	unless (member (symbol-name name) key-names 
		       :key #'symbol-name :test 'equal)
	append (list name val)))

(defmacro in (obj &rest choices)
  (let ((insym (gensym)))
    `(let ((,insym ,obj))
       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
                     choices)))))

(defmacro mean (&rest args)
  `(/ (+ ,@args) ,(length args)))

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
	  syms)
     ,@body))


;;; Mapping

(defun mapappend (fn list)
  (apply #'append (mapcar fn list)))


(defun mapcar-append-string-nontailrec (func v)
  "Concatenate results of mapcar lambda calls"  
  (aif (car v)
       (concatenate 'string (funcall func it)
		    (mapcar-append-string-nontailrec func (cdr v)))
       ""))


(defun mapcar-append-string (func v &optional (accum ""))
  "Concatenate results of mapcar lambda calls"  
  (aif (car v)
       (mapcar-append-string 
	func 
	(cdr v) 
	(concatenate 'string accum (funcall func it)))
       accum))

(defun mapcar2-append-string-nontailrec (func la lb)
  "Concatenate results of mapcar lambda call's over two lists"  
  (let ((a (car la))
	(b (car lb)))
    (if (and a b)
      (concatenate 'string (funcall func a b)
		   (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
      "")))
  
(defun mapcar2-append-string (func la lb &optional (accum ""))
  "Concatenate results of mapcar lambda call's over two lists"  
  (let ((a (car la))
	(b (car lb)))
    (if (and a b)
	(mapcar2-append-string 
	 func 
	 (cdr la) 
	 (cdr lb)
	 (concatenate 'string accum (funcall func a b)))
      accum)))
  

;;; Output

(defun indent-spaces (n &optional (stream *standard-output*))
  "Indent n*2 spaces to output stream"
  (when (numberp n)
    (let ((fmt (format nil "~~~DT" (+ n n))))
      (format stream fmt))))

(defun print-list (l &optional (output *standard-output*))
  "Print a list to a stream"
  (if (consp l)
    (progn
      (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
      t)
    nil))

(defun print-rows (rows &optional (ostrm *standard-output*))
  "Print a list of list rows to a stream"  
  (dolist (r rows)
    (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
    (terpri ostrm)))


;;; IO


(defstruct buf
  vec (start -1) (used -1) (new -1) (end -1))

(defun bref (buf n)
  (svref (buf-vec buf)
         (mod n (length (buf-vec buf)))))

(defun (setf bref) (val buf n)
  (setf (svref (buf-vec buf)
               (mod n (length (buf-vec buf))))
        val))

(defun new-buf (len)
  (make-buf :vec (make-array len)))

(defun buf-insert (x b)
  (setf (bref b (incf (buf-end b))) x))

(defun buf-pop (b)
  (prog1 
    (bref b (incf (buf-start b)))
    (setf (buf-used b) (buf-start b)
          (buf-new  b) (buf-end   b))))

(defun buf-next (b)
  (when (< (buf-used b) (buf-new b))
    (bref b (incf (buf-used b)))))

(defun buf-reset (b)
  (setf (buf-used b) (buf-start b)
        (buf-new  b) (buf-end   b)))

(defun buf-clear (b)
  (setf (buf-start b) -1 (buf-used  b) -1
        (buf-new   b) -1 (buf-end   b) -1))

(defun buf-flush (b str)
  (do ((i (1+ (buf-used b)) (1+ i)))
      ((> i (buf-end b)))
    (princ (bref b i) str)))


(defun file-subst (old new file1 file2)
  (with-open-file (in file1 :direction :input)
    (with-open-file (out file2 :direction :output
			 :if-exists :supersede)
      (stream-subst old new in out))))

(defun stream-subst (old new in out)
  (declare (string old new))
  (let* ((pos 0)
         (len (length old))
         (buf (new-buf len))
         (from-buf nil))
    (declare (fixnum pos len))
    (do ((c (read-char in nil :eof)
            (or (setf from-buf (buf-next buf))
                (read-char in nil :eof))))
        ((eql c :eof))
      (declare (character c))
      (cond ((char= c (char old pos))
             (incf pos)
             (cond ((= pos len)            ; 3
                    (princ new out)
                    (setf pos 0)
                    (buf-clear buf))
                   ((not from-buf)         ; 2
                    (buf-insert c buf))))
            ((zerop pos)                   ; 1
             (princ c out)
             (when from-buf
               (buf-pop buf)
               (buf-reset buf)))
            (t                             ; 4
             (unless from-buf
               (buf-insert c buf))
             (princ (buf-pop buf) out)
             (buf-reset buf)
             (setf pos 0))))
    (buf-flush buf out)))


;;; Tree Functions

(defun remove-tree-if (pred tree)
  "Strip from tree of atoms that satistify predicate"
  (if (atom tree)
      (unless (funcall pred tree)
	tree)
    (let ((car-strip (remove-tree-if pred (car tree)))
	  (cdr-strip (remove-tree-if pred (cdr tree))))
      (cond
       ((and car-strip (atom (cadr tree)) (null cdr-strip))
	(list car-strip))
       ((and car-strip cdr-strip)
	(cons car-strip cdr-strip))
       (car-strip
	car-strip)
       (cdr-strip
	cdr-strip)))))

(defun find-tree (sym tree)
  "Finds an atom as a car in tree and returns cdr tree at that positions"
  (if (or (null tree) (atom tree))
      nil
    (if (eql sym (car tree))
	(cdr tree)
      (aif (find-tree sym (car tree))
	  it
	(aif (find-tree sym (cdr tree))
	    it
	  nil)))))

;;; Files

(defun print-file-contents (file &optional (strm *standard-output*))
  "Opens a reads a file. Returns the contents as a single string"
  (when (probe-file file)
    (with-open-file (in file :direction :input)
      (let ((eof (gensym)))		    
	(do ((line (read-line in nil eof) 
		   (read-line in nil eof)))
	    ((eq line eof))
	  (format strm "~A~%" line))))))

(defun read-file-to-string (file)
  "Opens a reads a file. Returns the contents as a single string"
  (with-output-to-string (out)
    (with-open-file (in file :direction :input)
      (let ((eof (gensym)))		    
	(do ((line (read-line in nil eof) 
		   (read-line in nil eof)))
	    ((eq line eof))
	  (format out "~A~%" line))))))

(defun read-file-to-strings (file)
  "Opens a reads a file. Returns the contents as a list of strings"
  (let ((lines '()))
    (with-open-file (in file :direction :input)
      (let ((eof (gensym)))		    
	(do ((line (read-line in nil eof) 
		   (read-line in nil eof)))
	    ((eq line eof))
	  (push line lines)))
      (nreverse lines))))


;;; Formatting functions

(defun pretty-date (year month day &optional (hour 12) (m 0) (s 0))
  (multiple-value-bind (sec min hr dy mn yr wkday)
    (decode-universal-time
     (encode-universal-time s m hour day month year))
    (values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
		   "Friday" "Saturday" "Sunday")
		 wkday)
	    (elt '("January" "February" "March" "April" "May" "June"
		   "July" "August" "September" "October" "November"
		   "December")
		 (1- mn))
	    (format nil "~A" dy) (format nil "~A" yr)
	    (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))


(defun date-string (ut)
  (if (typep ut 'integer)
      (multiple-value-bind (sec min hr day mon year dow daylight-p zone)
	  (decode-universal-time ut)
	(declare (ignore daylight-p zone))
	(format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" 
		dow
		day
		(1- mon)
		year
		hr min sec))))


;; Benchmarking

(defun print-float-units (val unit)
  (cond
    ((< val 1d-6)
     (format t "~,2,9F nano~A" val unit))
    ((< val 1d-3)
     (format t "~,2,6F micro~A" val unit))
    ((< val 1)
     (format t "~,2,3F milli~A" val unit))
    ((> val 1d9)
     (format t "~,2,-9F giga~A" val unit))
    ((> val 1d6)
     (format t "~,2,-6F mega~A" val unit))
    ((> val 1d3)
     (format t "~,2,-3F kilo~A" val unit))
    (t
     (format t "~,2F ~A" val unit))))

(defun print-seconds (secs)
  (print-float-units secs "sec"))

(defmacro time-iterations (n &body body)
  (let ((i (gensym))
	(count (gensym)))
    `(progn
       (let ((,count ,n))
	 (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
	 (let ((t1 (get-internal-real-time)))
	   (dotimes (,i ,count)
	     ,@body)
	   (let* ((t2 (get-internal-real-time))
		  (secs (coerce (/ (- t2 t1)
				   internal-time-units-per-second)
				'double-float)))
	     (format t "~&Total time: ")
	     (print-seconds secs)
	     (format t ", time per iteration: ")
	     (print-seconds (coerce (/ secs ,n) 'double-float))))))))


(defun nsubseq (sequence start &optional (end (length sequence)))
  (make-array (- end start)
	      :element-type (array-element-type sequence)
	      :displaced-to sequence
	      :displaced-index-offset start))