;;;; -*- 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.5 2002/10/12 06:10:17 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 bind-when ((bind-var boundForm) &body body)
  `(let ((,bind-var ,boundForm))
      (declare (ignore-if-unused ,bind-var))
      (when ,bind-var
        ,@body)))
  
(defmacro bind-if ((bind-var boundForm) yup &optional nope)
  `(let ((,bind-var ,boundForm))
      (if ,bind-var
         ,yup
         ,nope)))

;; 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)))


;; 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)))


;;; 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"
  (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)))


;;; Symbol functions

(defmacro concat-symbol (&rest args)
  `(intern (concatenate 'string ,@args)))

(defmacro concat-symbol-pkg (pkg &rest args)
  `(intern (concatenate 'string ,@args) ,pkg))


;;; 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)
		    (do ((line (read-line in nil 'eof) 
			       (read-line in nil 'eof)))
			((eql 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)
      (do ((line (read-line in nil 'eof) 
		 (read-line in nil 'eof)))
	  ((eql 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)
      (do ((line (read-line in nil 'eof) 
		 (read-line in nil 'eof)))
	  ((eql 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))))