Port of Arc's functions and macros

arc-util.lisp

;;; Port of Arc's functions and macros

#+xyzzy
(require 'cmu_loop)

(in-package #+xyzzy :user
	    #-xyzzy :cl-user)

;;; functions
(defun idfn (x) x)

(defun testify (x)
  (if (functionp x) x
    #'(lambda (a) (equal x a))))

(defun mem (test seq)
  (member-if (testify test) seq))

(defun pos (test seq)
  (position-if (testify test) seq))

; rem
(defun rm (test seq)
  (remove-if (testify test) seq))

(defun keep (test seq) 
  (remove-if-not (testify test) seq))

#|
(defun pair (xs &optional (f #'list))
  (cond ((null xs)
	 nil)
	((null (cdr xs))
	 (list (list (car xs))))
	(t (cons (funcall f (car xs) (cadr xs))
		 (pair (cddr xs) f)))))
|#
(defun pair (xs &optional (f #'list))
  (cond ((null xs) nil)
	((null (cdr xs)) #1=(list (list (car xs))))
	(t (do* ((acc #2=(list (funcall f (car xs) (cadr xs))))
		 (tail acc)
		 (xs #3=(cddr xs) #3#))
	       ((null xs) acc)
	     (setf (cdr tail) (if (cdr xs) #2# #1#)
		   tail (cdr tail))))))

(defun firstn (n xs)
  (if (null n)
      xs
    (if (and (> n 0) xs)
	(cons (car xs) (firstn (- n 1) (cdr xs)))
      nil)))

(defun tuples (xs &optional (n 2) (f #'list))
  (if (null xs)
      nil
    (cons (apply f (firstn n xs))
	  (tuples (nthcdr n xs) n f))))

(defun split-at (seq &rest positions)
  (let ((from 0))
    (append (mapcar #'(lambda (to) (subseq seq from (setq from to)))
		    positions)
	    (list (subseq seq from)))))

(defun split-by (seq sep)
  (do* ((test (testify sep))
	(from 0 (1+ to))
	(to #1=(position-if test seq :start from) #1#)
	(acc))
      ((null to) (nreverse (push (subseq seq from) acc)))
    (push (subseq seq from to) acc)))

(defun alref (al key)
  (cadr (assoc key al :test #'equal)))

(defun ontree (f tree)
  (funcall f tree)
  (unless (atom tree)
    (ontree f (car tree))
    (ontree f (cdr tree))))


(defun range (start end)
  (loop for i from start to end
    collect i))

(defun sum (func seq)
  (apply #'+ (map 'list func seq)))

(defun orf (&rest fns)
  (let (result)
    #'(lambda (&rest args)
	(some #'(lambda (fs) (setq result (apply fs args))) fns)
	result)))

(defun andf (&rest fns)
  (let (result)
    #'(lambda (&rest args)
	(every #'(lambda (fs) (setq result (apply fs args))) fns)
	result)))

;; queue
(defun queue () (list nil nil 0))

(defun enq (obj q)
  (incf (caddr q))
  (if (null (car q))
      (setf (cadr q) (setf (car q) (list obj)))
    (setf (cdr (cadr q)) (list obj)
	  (cadr q) (cdr (cadr q))))
  (car q))

(defun deq (q)
  (unless (= (caddr q) 0)
    (decf (caddr q)))
  (pop (car q)))

(defun qlen (q) (caddr 2))

(defun qlist (q) (car q))

(defun enq-limit (val q &optional (limit 1000))
  (unless (< (qlen q) limit)
    (deq q))
  (enq val q))

;; math
(defun roundup (n)
  (let* ((base (floor n))
	 (rem (abs (- n base))))
    (if (>= rem 1/2) 
        (+ (if (> n 0) 1 -1) base)
        base)))

(defun nearest (n quantum)
  (* (roundup (/ n quantum)) quantum))

(defun avg (ns) (/ (apply #'+ ns) (length ns)))

(defun med (ns &key (test #'>))
  (nth (round (/ (length ns) 2)) (sort ns test)))


;;; macros
;; from onlisp 12-4 _f macro
(defmacro zap (op place &rest args)
  (multiple-value-bind (vars forms var set access)
      (get-setf-method place)
    `(let* (,@(mapcar #'list vars forms)
	    (,(car var) (,op ,access ,@args)))
       ,set)))


(defmacro w/uniq (names &body body)
  (let ((binds (mapcar #'(lambda (s) `(,s (make-symbol ,(symbol-name s))))
		       (if (consp names) names (list names)))))
    `(let ,binds ,@body)))

(defmacro with (params &body body)
  `(let ,(pair params) ,@body))

(defmacro withs (params &body body)
  `(let* ,(pair params) ,@body))

(defmacro accum (accfn &body body)
  (w/uniq (gacc ga)
    `(let (,gacc)
       (flet ((,accfn (,ga) (push ,ga ,gacc)))
	 ,@body)
       (nreverse ,gacc))))


(defmacro drain (expr &optional eof)
  (w/uniq (gv gtest gacc)
    `(let ((,gtest (testify ,eof)) ,gacc)
       (do ((,gv ,expr ,expr))
	   ((funcall ,gtest ,gv) (nreverse ,gacc))
	 (push ,gv ,gacc)))))

(defmacro n-of (n &rest exprs)
  `(accum #1=#:ga
     (dotimes (#:i ,n)
       ,@(loop for e in exprs
	   collect `(#1# ,e)))))

#+nil
(defmacro in (x &rest choices)
  (w/uniq (g)
    `(with (,g ,x)
       (or ,@(mapcar #'(lambda (c) `(equal ,g ,c)) choices)))))

(defmacro rfn (name params &body body)
  `(labels ((,name ,params ,@body))
     #',name))

(defmacro afn (params &body body)
  `(labels ((self ,params ,@body))
     #'self))

#|
(defmacro aloop (start test update &body body)
  (w/uniq (gfn gparm)
    `(with ,start
       (funcall (rfn ,gfn (,gparm)
		  (when ,gparm
		    ,@body ,update (,gfn ,test)))
		,test))))

(defmacro for (v init max &body body)
  (w/uniq (gi gm)
    `(with (,v nil ,gi ,init ,gm (+ ,max 1))
       (aloop (setq ,v ,gi) (< ,v ,gm) (incf ,v)
	 ,@body))))
|#
(defmacro aloop (start test update &body body)
  `(progn ,start
     (loop while ,test
       do (progn ,@body ,update))))

(defmacro for (v init max &body body)
  (w/uniq (gm)
    `(do ((,v ,init (1+ ,v))
	  (,gm ,max))
	 ((< ,gm ,v))
       ,@body)))

#|
(mac down (v init min . body)
  (w/uniq (gi gm)
    `(with (,v nil ,gi ,init ,gm (- ,min 1))
       (aloop (setq ,v ,gi) (> ,v ,gm) (decf ,v)
         ,@body))))
|#

(defmacro repeat (n &body body)
  `(for ,(gensym) 1 ,n ,@body))

(defmacro whilet (var test &body body)
  `(do ((,var ,test ,test))
       ((not ,var))
     ,@body))

(defmacro on (x xs &body body)
  `(let ((index 0))
     (map () #'(lambda (,x) ,@body (incf index))
	  ,xs)))

(defmacro each (var expr &body body)
  (w/uniq (gseq)
    `(let ((,gseq ,expr))
       (if (hash-table-p ,gseq)
	   (maphash #'(lambda ,var ,@body) ,gseq)
	 (loop for ,var in ,gseq
	   do (progn ,@body))))))

(defmacro trav (x . fs)
  (w/uniq g
    `(labels
	 ((self (,g)
	    (when ,g
	      ,@(mapcar #'(lambda (f) `(,f ,g)) fs))))
       (self ,x))))


;; table
(defun table (&rest inits)
  (let ((tbl (make-hash-table :test 'equal)))
    (pair inits #'(lambda (k v) (setf (gethash k table) v)))
    tbl))

(defun fill-table (table data)
  (pair data #'(lambda (k v) (setf (gethash k table) v)))
  table)

(defun keys (tbl)
  (accum a (each (k v) tbl (a k))))

(defun vals (tbl)
  (accum a (each (k v) tbl (a v))))

(defun tablist (tbl)
  (accum a (maphash #'(lambda (&rest pair) (a pair)) tbl)))

(defmacro w/table (sym &body body)
  `(let ((,sym (table))) ,@body ,sym))

(defun counts (seq)
  (w/table c
    (dolist (e seq)
      (incf (gethash e c 0)))))


;;; io
(defun pr (&rest objs)
  (format t "~{~A~}" objs)
  (car objs))

(defun prt (&rest objs)
  (mapc #'(lambda (o) (if o (princ o))) objs)
  (car objs))

(defun prn (&rest objs)
  (format t "~{~A~}~%" objs)
  (car objs))

(defun prs (objs)
  (format t "~{~A~^ ~}" objs)
  objs)

(defun prall (objs &optional (h "") (s ","))
  (let ((fmt (format nil "~A~~{~~A~~^~A~~}" h s)))
    (format t fmt objs)
    objs))

(defun readb (&optional (is *standard-input*))
  (read-byte is nil nil))

(defun readc (&optional (is *standard-input*))
  (read-char is nil nil))

(defun readline (&optional (is *standard-input*))
  (read-line is nil nil))

(defun readall (&optional (is *standard-input*))
  (drain (read is nil nil t)))

(macrolet ((falias (f g)
	     `(setf (symbol-function ',f)
		    (symbol-function ',g))))
  (falias instring make-string-input-stream)
  (falias outstring make-string-output-stream)
  (falias inside get-output-stream-string))

(defmacro w/infile ((var file . rest) &body body)
  `(with-open-file (,var ,file
		    :direction :input
		    :if-does-not-exists :error)
     ,@(if rest `((w/infile ,rest ,@body))
	 body)))

(defmacro w/outfile ((var file . rest) &body body)
  `(with-open-file (,var ,file
		    :direction :output
		    :if-exists :overwrite
		    :if-does-not-exist :create)
     ,@(if rest `((w/outfile ,rest ,@body))
	 body)))

(defmacro w/appendfile ((var file . rest) &body body)
  `(with-open-file (,var ,file
		    :direction :output
		    :if-exists :append
		    :if-does-not-exist :create)
     ,@(if rest `((w/appendfile ,rest ,@body))
	 body)))


(defmacro w/instring ((var str . rest) &body body)
  `(with-input-from-string (,var ,str)
     ,@(if rest `((w/instring ,rest ,@body))
	 body)))

(defmacro w/outstring (vars &body body)
  `(let ,(mapcar #'(lambda (p) `(,p (outstring)))
		 vars)
     ,@body))

(defmacro fromstring (str &body body)
  `(w/instring (*standard-input* ,str)
     (let ((*terminal-io* *standard-input*))
       ,@body)))

(defmacro tostring (&body body)
  `(w/outstring (*standard-output*)
     ,@body
     (inside *standard-output*)))

(defun allchars (is)
  (tostring (drain (prt (readc is)))))

(defun filechars (path)
  (w/infile (is path)
    (allchars is)))

#+xyzzy
(progn
  (defmacro w/buf ((var buf) &body body)
    `(let ((,var (make-buffer-stream ,buf)))
       (prog1
	   (progn ,@body)
	 (close ,var))))

  (defmacro frombuf (buf &body body)
    `(w/buf (*standard-input* ,buf)
       (let ((*terminal-io* *standard-input*))
	 ,@body)))

  (defun bufchars (buf)
    (save-excursion
      (set-buffer buf)
      (buffer-substring (point-min) (point-max))))
  
  (on l
      '((0 tostring)
	(1 with withs w/uniq accum afn
	   w/infile w/outfile w/appendfile w/table
	   w/instring w/outstring fromstring repeat
	   w/buf frombuf bufchars)
	(2 rfn whilet on each)
	(3 aloop for))

    (on sym (cdr l)
      (setf (get sym 'lisp-indent-hook) (car l))))
  )

(provide "arc-util")