Paste number 132522: arc.lisp

Paste number 132522: arc.lisp
Pasted by: waterhouse
When:8 years, 8 months ago
Share:Tweet this! | http://paste.lisp.org/+2U96
Channel:None
Paste contents:
Raw Source | XML | Display As
;There may be some redundant or just plain stupid code
; that I haven't deleted yet.
;A couple of these things are imported from On Lisp, the rest
; are written by me.
;Idiosyncrasies (some of them):
; =: use setf
; map: use mapcar
; if: use iff ("if and only if")
; let: if you want destructuring, use dsb, else use with
; with: (with x 1 ...) or (with (x 1 y 2) ...)
; tuples: (tuples n xs) rather than (tuples xs &optional (n 2))
; def, mac: use &optional for optionals, but can use . for rest
; is: simply implemented as a synonym for equal

(defmacro defdelim (left right parms &body body)
  `(ddfn ,left ,right #'(lambda ,parms ,@body)))

(let ((rpar (get-macro-character #\) )))
  (defun ddfn (left right fn)
    (set-macro-character right rpar)
    (set-macro-character left
                         #'(lambda (stream char)
                             (declare (ignore char))
                             (apply fn
                                    (read-delimited-list right stream t))))))

(defdelim #\[ #\] (&rest args)
  `(lambda (_) (,@args)))

(defun accumulate (comb f xs init next done)
  (do ((tt init (funcall comb (funcall f xs) tt))
       (xs xs (funcall next xs)))
      ((funcall done xs) tt)))

(defun firstn (n xs)
  (if (or (= n 0) (null xs))
      nil
      (cons (car xs) (firstn (1- n) (cdr xs)))))

(defun tuples (n xs)
  (nreverse (accumulate #'cons [firstn n _] xs nil [nthcdr n _] #'null)))

(defmacro xloop (binds &body body)
  `(labels ((next ,(mapcar #'car (tuples 2 binds)) ,@body))
     (next ,@(mapcar #'cadr (tuples 2 binds)))))

(defun dots (xs)
  (mapcar [if (consp _)
              (dots _)
              _]
          (append (butlast xs)
                  (let ((x (last xs)))
                    (if (cdr x)
                        `(,(car x) &rest ,(cdr x))
                        x)))))
(defun flatten (xs)
  (labels ((slave (xs total)
                  (cond ((null xs) total)
                        ((consp (car xs))
                         (slave (cdr xs) (slave (car xs) total)))
                        (t (slave (cdr xs) (cons (car xs) total))))))
    (nreverse (slave xs nil))))
(defun restify (arglist)
  (if (null arglist)
      '()
      (if (atom arglist)
          `(&rest ,arglist)
          (dots arglist))))
(defmacro mac (name args &body body)
  `(defmacro ,name ,(restify args) ,@body))
(mac def (name args . body)
  `(defun ,name ,(restify args) ,@body))

(mac with (binds . body)
  (if (atom binds)
      `(let ((,binds ,(car body)))
         ,@(cdr body))
      `(let ,(tuples 2 binds)
         ,@body)))
(mac withs (binds . body)
  `(let* ,(tuples 2 binds)
     ,@body))


(def mkstr args
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))
(def symb args
  (values (intern (apply #'mkstr args))))

(mac w/uniq (vars . body)
  (if (atom vars)
      `(let ((,vars (gensym)))
         ,@body)
      `(let ,(mapcar [list _ '(gensym)]
                     vars)
         ,@body)))

(mac abbrev (new old)
  `(mac ,new args
     `(,',old ,@args)))
(mac abbrevs args
  `(progn
    ,@(mapcar (lambda (x) `(abbrev ,@x))
              (tuples 2 args))))
(abbrevs mvb multiple-value-bind
         ;dsb destructuring-bind
         ; I seem to recall something going wrong with the built-in dsb,
         ;  but I forget what
         )

(mac synonym args
  `(setf ,@(mapcar (lambda (x)
                     `(symbol-function ',x))
                   args)))

(synonym no null
         trunc truncate
         len length
         uniq gensym
         cut subseq
         rev reverse
         is equal
         macex macroexpand
         macex1 macroexpand-1
         err error
         keep remove-if-not)

(def last1 (xs)
  (car (last xs)))

(mac iff args
  (with u (tuples 2 args)
    `(cond ,@(butlast u)
           ,(with h (last1 u)
              (if (no (cdr h))
                  `(t ,(car h))
                  h)))))
(def rand (a &optional (b nil))
  (if b
      (+ a (random (- b a)))
      (random a)))

(mac dsb (vars vals . body)
  (w/uniq gval
    `(with ,gval ,vals
       (dsb1 ,vars ,gval ,@body))))
(mac dsb1 (vars vals . body)
  (cond ((no vars) `(progn ,@body))
        ((atom vars) `(with ,vars ,vals ,@body))
        (t `(dsb1 ,(car vars) (car ,vals)
                  (dsb1 ,(cdr vars) (cdr ,vals)
                        ,@body)))))



(def flatp (xs)
  (or (no xs)
      (and (consp xs)
           (atom (car xs))
           (flatp (cdr xs)))))


(mac fn (args . body)
  (with args (restify args)
    (if (flatp (cut args 0 (or (position '&optional args) (len args))))
        `(lambda ,args ,@body)
        (w/uniq gargs
          `(lambda (&rest ,gargs)
             (dsb ,args ,gargs
               ,@body))))))


(mac until (test . body)
  `(do ()
       (,test)
       ,@body))
(mac while (test . body)
  `(until (not ,test) ,@body))

(mac for (var start stop . body)
  (w/uniq gstop
    `(do ((,var ,start (1+ ,var))
          (,gstop ,stop))
         ((> ,var ,gstop))
         ,@body)))
(mac repeat (n . body)
  `(for ,(uniq) 1 ,n ,@body))
(mac forlen (var xs . body)
  `(for ,var 0 (1- (len ,xs)) ,@body))
(mac n-of (n x)
  (w/uniq u
    `(with ,u nil
       (repeat ,n (push ,x ,u))
       (nreverse ,u))))
(mac aif (a . rest)
  `(with it ,a
     (if it
         ,@rest)))
(mac awhen (a . rest)
  `(with it ,a
     (when it
       ,@rest)))
(mac zap (func . args)
  `(setf ,(car args) (,func ,@args)))
(mac zaps (func . targs)
  `(progn ,@(mapcar (fn (x) `(zap ,func ,x))
                    targs)))
(mac aps (sym)
  `(apropos ,(symbol-name sym)))

(def flatp1 (xs)
  (apply #'append
         (mapcar [if (atom _) (list _) _]
                 xs)))
(mac each (var xs . body)
  (if (atom var)
      (w/uniq gxs
        `(with ,gxs ,xs
	       (dolist (,var ,gxs) ,@body)))
;           (typecase ,gxs
;             (list (dolist (,var ,gxs) ,@body))
;            (array ,(w/uniq i `(forlen ,i ,gxs
;                                  (with ,var (aref ,gxs ,i)
;                                    ,@body))))
             ;(hash-table (maphash (fn (,(uniq) ,var) ,@body) ,gxs))
      (w/uniq gvar
        `(each ,gvar ,xs
           (dsb ,var ,gvar
             ,@body)))))
(def trues (func xs)
  (with u nil
    (each x xs
      (if (funcall func x)
          (push x u)))
    (nreverse u)))


(def range (a b &optional (d 1))
  (with u nil
    (until (> a b)
      (push a u)
      (incf a d))
    (nreverse u)))
(def deep-map (f xs)
  (mapcar [if (consp _)
              (deep-map f _)
              (funcall f _)]
          xs))
(def testify (f)
  (if (functionp f)
      f
      (fn (x) (is x f))))
(def all (func xs)
  (or (no xs)
      (and (funcall func (car xs))
           (all func (cdr xs)))))



(def tree-replace (test new tree)
  (with f (testify test)
    (deep-map [if (funcall f _) new _]
              tree)))
(def id (x) x)

(def pr args
  (each x args (princ x))
  (last1 args))
(def prn args
  (prog1 (apply #'pr args)
         (princ #\newline)))
(def prs args
  (each x args
    (princ x)
    (princ " "))
  ;  (princ #\newline)
  (last1 args))
(def prsn args
  (each x args
    (princ x)
    (princ " "))
  (princ #\newline)
  (last1 args))


(mac defmemo (name args . body)
  (with (tbl (symb name "-memo-table")
         has-decl (and (consp (car body))
                       (eq 'declare (caar body))))
    `(with ,tbl (make-hash-table :test #'equal)
       ;default test is #'eql; (eql (list 1) (list 1)) -> nil
       (def ,name ,args
         (mvb (val win) (gethash (list ,@args) ,tbl)
           ,(if has-decl
                (car body))
           (if win
               val
               (setf (gethash (list ,@args) ,tbl)
                     (progn ,@(if has-decl
                                  (cdr body)
                                  body)))))))))


;PG:
(defun memoize (f)
  (let ((cache (make-hash-table :test #'equal)))
    #'(lambda (&rest args)
        (multiple-value-bind (val win) (gethash args cache)
                             (if win
                                 val
                                 (setf (gethash args cache)
                                       (apply f args)))))))


(mac ucase (var . args)
  (w/uniq gvar
    `(with ,gvar ,var
       (cond
         ,@(if (evenp (len args))
               (mapcar (fn ((a b))
                         `((equal ,gvar ,a)
                           ,b))
                       (tuples 2 args))
               (append (mapcar (fn ((a b))
                                 `((equal ,gvar ,a)
                                   ,b))
                               (tuples 2 (butlast args)));ugh, so ugly, but oh well
                       `((t ,(last1 args)))))))))

(def always (x) (fn args (declare (ignore args)) x))
(def andf args
  (iff (no args)
       (always t)
       (no (cdr args))
       (car args)
       [and (funcall (car args) _)
            (funcall (apply #'andf (cdr args))
                     _)]))


(mac aiff args
  (iff (no args)
       nil
       (no (cdr args))
       (car args)
       `(with it ,(car args)
          (if it
              ,(cadr args)
              (aiff ,@(cddr args))))))
(def compose args
  (if (no (cdr args))
      (car args)
      (fn uargs
        (funcall (car args)
                 (apply (apply #'compose (cdr args))
                        uargs)))))


(def random-element (xs)
  (elt xs (rand (len xs))))


(def pos (x xs . keys)
  (apply #'position x xs
         (if (functionp x)
             (list* :test #'funcall keys)
             keys)))
(def mem (test struc . args)
  (if (functionp test)
      (apply #'member test struc :test #'funcall args)
      (apply #'member test struc args)))
(def avg args
  (/ (apply #'+ args)
     (len args)))


(mac in (a . rest)
  (w/uniq ga
    `(with ,ga ,a
       (or ,@(mapcar (fn (x) `(is ,ga ,x))
                     rest)))))


(def sumlist (f xs)
  (with n 0
    (each x xs
      (incf n (funcall f x)))
    n))
(def sum (f a b)
  (accumulate #'+ f a 0 #'1+ [> _ b]))


(mac whilet (var test . body)
  `(do ((,var ,test ,test))
       ((not ,var))
       ,@body))
(mac awhile (test . body)
  `(whilet it ,test ,@body))


(mac tostring args
  (w/uniq s
    `(with-output-to-string (,s)
       (with *standard-output* ,s
         ,@args))))
(mac fromstring (str . body)
  (w/uniq s
    `(with-input-from-string (,s ,str)
       ,@body)))


(mac w/infile (name file . body)
  `(with-open-file (,name ,file)
     ,@body))

(mac w/instring (s . body)
  `(with-input-from-string (*standard-input* ,s)
     ,@body))


(mac w/outfile (name file . body)
  `(with-open-file (,name ,file :direction :output)
     ,@body))

(synonym dedup remove-duplicates)


(def square (x)
  (* x x))


(def compare (cmp score)
  (fn (x y) (funcall cmp (funcall score x) (funcall score y))))


(mac aand args
  (with u 'it
    (each x (rev args)
      (setf u `(aif ,x
                    ,u)))
    u))



(mac pushend (a xs)
  `(if (no ,xs)
       (setf ,xs (list ,a))
       (progn (setf (cdr (last ,xs)) (list ,a))
              ,xs)))

(def orf args
  (iff (no args)
       (err "no args to orf")
       (no (cdr args))
       (car args)
       (fn uargs
         (or (apply (car args) uargs)
             (apply (apply #'orf (cdr args))
                    uargs)))))



(mac wipe args
  `(setf ,@(flatten
            (mapcar [list _ nil] args))))

(mac between (var expr within . body)
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
         (unless ,first ,within)
         (wipe ,first)
         ,@body))))



(def treewise (f base tree)
  (if (atom tree)
      (funcall base tree)
      (funcall f (treewise f base (car tree)) 
               (treewise f base (cdr tree)))))


(def inc (n) (+ n 1))
(def dec (n) (- n 1))
(abbrev do1 prog1)
(def isnt (a b) (no (is a b)))



(def insert-sorted (< x xs)
  (iff (no xs)
       (list x)
       (funcall < (car xs) x)
       (cons (car xs) (insert-sorted < x (cdr xs)))
       (cons x xs)))


(def keys (tb)
  (with u nil
    (maphash (fn (key val)
               (declare (ignore val))
               (push key u))
             tb)
    u))

(def count-up (xs)
  (with (u (make-hash-table :test #'equal) ch nil)
    (each x xs
      (incf (gethash x u 0)))
    (maphash (fn (x y) (push (list x y) ch))
             u)
    ch))

(def collect (xs)
  (with (u nil last (car xs) n 0)
    (each x xs
      (if (is x last)
          (incf n)
          (progn (push (list last n) u)
                 (setf n 1 last x))))
    (when last
      (push (list last n) u))
    (nreverse u)))


(def mapn (f a b &optional (d 1))
  (nreverse (accumulate #'cons f a nil [+ _ d] [> _ b])))


(def file-exists (f)
  (with-open-file (meh f :direction :probe)
    (if meh t nil)))


(def mappend (f . xses)
  (apply #'append (apply #'mapcar f xses)))


(mac on (var xs . body)
  `(with index -1
     (each ,var ,xs
           (incf index)
           ,@body)))

(def but-nth (n xs)
  (if (is n 0)
      (cdr xs)
      (cons (car xs) (but-nth (- n 1) (cdr xs)))))

(mac accum (name . body)
  (w/uniq (xs tail)
    `(withs (,xs (list nil) ,tail ,xs)
       (flet ((,name (x)
                     (setf (cdr ,tail) (list x)
                           ,tail (cdr ,tail))))
	 ,@body
	 (cdr ,xs)))))

(def whitec (c)
  (in c #\space #\newline #\tab #\return))

(mac as (type x)
     `(coerce ,x ',type))

(def tokens (s &optional (sep #'whitec))
  (with sep (typecase sep
	      (function sep)
	      (character [char= _ sep]))
	(xloop (i 0 tok nil toks nil)
	       (iff (= i (len s))
		    (nreverse (if tok
				  (cons (as string (rev tok)) toks)
				  toks))
		    (funcall sep (char s i))
		    (next (inc i) nil (if tok
					  (cons (as string (rev tok)) toks)
					  toks))
		    (next (inc i) (cons (char s i) tok) toks)))))

(def wrn args
  (mapc #'write args)
  (prn))

(def trim (s &optional (where 'both) (test #'whitec))
  (withs (f   (testify test)
           p1 (pos (complement f) s))
    (if p1
        (cut s 
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (with i (- (len s) 1)
                 (while (and (> i p1) (funcall f (char s i)))
                   (decf i))
                 (+ i 1))))
        "")))

(mac w/stdout (s . body)
     `(with *standard-output* ,s ,@body))
(mac w/stdin (s . body)
     `(with *standard-input* ,s ,@body))

(def num->digs (n &optional (base 10))
  (xloop (n n xs nil)
    (if (zerop n)
        xs
        (next (floor n base) (cons (mod n base) xs)))))
(def digs->num (xs &optional (base 10))
  (xloop (xs xs tt 0)
    (if (no xs)
        tt
        (next (cdr xs) (+ (car xs) (* base tt))))))
(def find-int (f &optional (start 0))
  (if (funcall f start)
      start
      (find-int f (+ start 1))))

(def pad (str n &optional (align 'right))
  (with padding (make-string (- n (len str)) :initial-element #\space)
    (when (isnt align 'left)
      (rotatef str padding))
    (string-append str padding)))

(def grid (xses)
  (with lens (mapcar [reduce #'max (mapcar #'len _)]
                     (apply #'mapcar #'list xses))
    (mapc (fn (xs)
            (apply #'prsn (mapcar #'pad xs lens)))
          xses)))

This paste has no annotations.

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.