CL utility snippets

_sample.lisp

;;; CL utility snippets -- MIT LICENSE 
;;;
;;; originally starting from porting p59c.hs (https://gist.github.com/nfunato/9559350#file-p59c-hs) to CL,
;;; which uses
;;;     delay, force (promise.lisp)
;;;     xsequence    (xsequence.lisp)
;;;     xtranspose   (xtranspose.lisp)
;;;     groups-of, xsplit, xmerge (groups-of.lisp)
;;; 2015-09-27 tconc and lconc (xconc.lisp, xconc.scm)
;;; 2015-09-29 random test stuff (for-random-test.lisp) 
;;; 2015-12-29 compose compose2 curry lcurry rcurry sigma (functions.lisp)
;;; 2015-12-29 alist trie (trie.lisp)
;;; 2016-01-10 a few map functions for array (map-for-array.lisp)

(defun is-space   (ch)  (member ch '(#\Space #\Tab #\Return #\Linefeed)))
(defun is-print   (ch)  (or (is-space ch) (graphic-char-p ch)))
(defun sum        (xs)  (apply #'+ xs))
(defun min-by-car (xs)  (reduce (lambda (a b) (if (< (CAR a) (CAR b)) a b)) xs))
(defun list->str  (xs)  (map 'string #'identity xs))

(defun calc-attr (xs) (length (remove-if-not #'is-space xs)))
(defun calc-gap  (xs) (/ 1.0 (1+ (sum xs))))

(defun decode (c xs &aux (cc (char-code c)))
  (mapcar (lambda (x) (code-char (logxor cc x))) xs))

(defun list3 (xs)
  (loop for c across "abcdefghijklmnopqrstuvwxyz"
        for p = (decode c xs)
        when (every #'is-print p)
        collect (list (calc-attr p) c p)))

(defun mix3 (triple)
  (destructuring-bind ((a0 c0 p0) (a1 c1 p1) (a2 c2 p2)) triple
    (list (calc-gap  (list a0 a1 a2))
          (list->str (list c0 c1 c2))
          (delay (list->str (xmerge (list p0 p1 p2)))))))

(defun p59 (xs)
  (min-by-car (mapcar #'mix3 (xsequence (mapcar #'list3 (xsplit 3 xs))))))

(defun read-cipher (path)
  (flet ((modify (line) (substitute #\Space #\, line)))
    (read-from-string
     (with-output-to-string (ost)
       (princ "( " ost)
       (with-open-file (ist path :direction :input)
         (loop for x = (read-line ist nil) while x do (princ (modify x) ost)))
       (princ " )" ost)))))

(defun map-ord (xs) (map 'list #'char-code xs))

(defun main ()
  (sum (map-ord (force (third (p59 (read-cipher #p"cipher1.txt")))))))

for-random-test.lisp

;;; Random test stuff

(defvar *saved-initial-rndst* nil)
(defvar *permanent-saved-initial-rndst* nil)
(defun DUMP-RNDST ()
  (print *saved-initial-rndst*)
  (format t "Please add '(setf *permanent-saved-initial-rndst* ...)' at the end of this file."))
(defun RESTORE-RNDST ()
  (setf *saved-initial-rndst* *permanent-saved-initial-rndst*))

(defvar *rndst* nil)
(defvar *rnd-ctr* 0)
(defvar *rnd-ulimit* 10000)
(defun REFRESH-RNDST ()
  (setf *saved-initial-rndst* (make-random-state t))
  nil)
(defun reset-rndst ()   ; intended to be internal for reset-rnd
  ;; reset-rndst needs preparation by calling (restore-rndst) or (refresh-rndst)
  (assert *saved-initial-rndst*)
  (setf *rndst* (make-random-state *saved-initial-rndst*)))
(defun RND ()           ; return random number from 0 below *rnd-ulimit*
  (incf *rnd-ctr*)
  (random *rnd-ulimit* *rndst*))
(defun RESET-RND (&optional (n 0))
  ;; reset-rndst needs preparation by calling (restore-rndst) or (refresh-rndst)
  (reset-rndst)
  (loop for i from 1 to n do (rnd))
  (setf *rnd-ctr* n)
  (values))

(defun RANDOMIZE-SEQ (seq)
  (map (type-of seq)        ; sometimes you might want to use map-into
       #'car
       (sort (map 'vector (lambda (x) (cons x (random 1d0))) seq)
             #'<
             :key #'cdr)))

(defun iota (count &optional (start 0) (step 1))
  (loop for i from 1 to count
        for x = start then (+ x step)
        collect x))

functions.lisp

(defun compose (g &rest gs)
  (flet ((fn (f v) (funcall f v)))
    (lambda (x) (reduce #'fn (cons g gs) :initial-value x :from-end t))))
(defun compose2 (f g) (lambda (x) (funcall f (funcall g x))))
(defun curry   (fn a) (lambda (&rest args) (apply fn a args)))
(defun lcurry  (fn a) (lambda (b) (funcall fn a b)))
(defun rcurry  (fn b) (lambda (a) (funcall fn a b)))
(defun sigma (fn b e) (loop for i from b to e summing (funcall fn i)))

groups-of.lisp

(defun take (n xs) (loop for i from 0 below n for x in xs collect x))

(defun groups-of (n xs)
  (cond ((zerop n) (error "groups-of"))
        ((null xs) '())
        (t (cons (take n xs) (groups-of n (nthcdr n xs))))))

(defun xsplit (n xs) (xtranspose (groups-of n xs)))
(defun xmerge  (xss) (apply #'concatenate 'list (xtranspose xss)))

map-for-array.lisp

;;; someday plural input params should be handled by array-foreach, array-map, and array-map!

;;;-------------------------------------------------------------------
;; the following four functions meant to be dimension-independent.

(defun array-foreach1 (fn arr)
  (loop for i from 0 below (array-total-size arr) do
    (funcall fn (row-major-aref arr i)))
  nil)

(defun array-map1! (dest-arr fn arr)
  (loop for i from 0 below (array-total-size arr) do
    (setf (row-major-aref dest-arr i) (funcall fn (row-major-aref arr i))))
  dest-arr)

(defun array-map1 (fn arr)
  (array-map1! (make-array (array-dimensions arr)) fn arr))

(defun copy-array (arr)
  (array-map1 #'identity arr))

mapappend.lisp

;;; See also xtranspose.lisp

;;; like mapcar, but the results are appended
(defun mapappend (fn &rest xss)
  (if (some #'null xss)
      '()
      (append (apply fn (mapcar #'car xss))
              (apply #'mapappend fn (mapcar #'cdr xss)))))

;;; the following snippets are just for memo

(defun split-lists2 (xss &optional (all-p t))
  (assert (not (null xss)))
  (flet ((analyze (x) (if (null x) (list nil '() t) (list (car x)(cdr x) nil))))
    (loop for xs in xss
          for (a d n?) = (analyze xs)
          collect a  into kars
          collect d  into kdrs
          collect n? into nulls?
          finally (return
                    (values kars
                            kdrs
                            (funcall (if all-p #'every #'some)
                                     #'identity
                                     nulls?))))))

(defun mapappend-1 (fn all? xss)
  (labels ((sub (xss)
             (multiple-value-bind (kars kdrs null?) (split-lists2 xss all?)
               (if null?
                   '()
                   (append (apply fn kars) (sub kdrs))))))
    (sub xss)))

;(defun mapappend (fn &rest xss) (mapappend-1 fn nil xss))
(defun xmapappend (fn &rest xss) (mapappend-1 fn t   xss))

perm.lisp

;;; subs/interleave/perm/subbags from "Programming in Haskell" by Graham Hutton

(defun mapcons (x yss)
  (mapcar (lambda (ys) (cons x ys)) yss))

(defun concat-map (fn xs)
  ;; not use mapcan (nconc for append) intentionally, considering arbitrary fn
  (apply #'append (mapcar fn xs)))

(defun subs (zs)
  (cond ((null zs) (list '()))
        (t         (destructuring-bind (x . xs) zs
                     (let ((yss (subs xs)))
                       (append yss (mapcons x yss)))))))

(defun interleave (x zs)
  (cond ((null zs) (list (list x)))
        (t         (destructuring-bind (y . ys) zs
                     (cons (cons x zs)
                           (mapcons y (interleave x ys)))))))

(defun perms (zs)
  (cond ((null zs) (list '()))
        (t         (destructuring-bind (x . xs) zs
                     (concat-map (lambda (ys) (interleave x ys))
                                 (perms xs))))))

(defun subbags (xs)
  (concat-map #'perms (subs xs)))

#| From "Programming in Haskell" by Graham Hutton

-- subs returns all subsequences of a list, which are given by
-- all possible combinations of excluding or including each element.
subs :: [a] -> [[a]]
subs [] = [[]]
subs (x : xs) = yss ++ map (x:) yss
  where yss = subs xs

-- interleave returns all poassible ways of inserting a new element
-- into a list
interleave :: a -> [a] -> [[a]]
interleave x [] = [[x]]
interleave x (y : ys)=(x : y : ys) : map (y:) (interleave x ys)

-- perms returns all permutation of a list, which are given by
-- all possible reorderings of the elements
perms :: [a] -> [[a]]
perms [] = [[]]
perms (x : xs) = concatMap (interleave x) $ perms xs

-- subbags returns all subbags of a list, which are given by
-- all possible ways of selecting zero or more elements in any order,
-- can be defined simply by considering all permutations of all subsequences:
subbags :: [a] -> [[a]]
subbags xs = concatMap perms $ subs xs

{- examples

> subs [1, 2, 3]
[[], [3], [2], [2, 3], [1], [1, 3], [1, 2], [1, 2, 3]]

> interleave 1 [2, 3, 4]
[[1, 2, 3, 4], [2, 1, 3, 4], [2, 3, 1, 4], [2, 3, 4, 1]]
> perms [1, 2, 3]
[[1, 2, 3], [2, 1, 3], [2, 3, 1], [1, 3, 2], [3, 1, 2], [3, 2, 1]]

> subbags [1, 2, 3]
[[ ], [3], [2], [2, 3], [3, 2], [1], [1, 3], [3, 1], [1, 2], [2, 1], [1, 2, 3], [2, 1, 3], [2, 3, 1], [1, 3, 2], [3, 1, 2], [3, 2, 1]]

-}

|#

#|
;;; L-99 problem27

(defvar *names* '(aldo beat carla david evi flip gary hugo ida))

(defun p27 (&optional (names *names1*))
  (canonicalize
   (groups '(2 3 4) names)))

(defun lcurry  (f a)   (lambda (b) (funcall f a b)))
(defun mapcons (x yss) (mapcar (lcurry #'cons x) yss))

(defun comb (n r xs)
  (cond ((or (zerop r) (null xs)) '(()))
        ((= n r) (list (copy-seq xs)))
        (t
         (destructuring-bind (kar . kdr) xs
           (nconc (comb (1- n) r kdr)
                  (mapcons kar (comb (1- n) (1- r) kdr)))))))

(defun combinations (r xs &aux (n (length xs)))
  (assert (>= n r 0))
  (assert (listp xs))
  (comb n r xs))

(defun groups (sizes set)
  (cond ((null sizes) '(()))
        ((null set)   (error "groups"))
        (t
         (mapcan (lambda (grp)
                   (mapcons grp
                            (groups (cdr sizes) (set-difference set grp))))
                 (combinations (car sizes) set)))))

(defun name=       (n1 n2) (string= (string n1) (string n2)))
(defun name<       (n1 n2) (string< (string n1) (string n2)))
(defun sort-names  (names) (sort (copy-seq names) #'name<))

(defun tree<= (t1 t2)
  ;; assuming two trees are isomorphic
  (flet ((fn (x y)
           (cond ((and (null x) (null y)) t)
                 ((or  (null x) (null y)) (error "tree<="))
                 ((name= x y)             t)
                 (t                       (return-from tree<= (name< x y))))))
    (tree-equal t1 t2 :test #'fn)
    t))

(defun canonicalize (groups)
  (sort (mapcar (lambda (g) (mapcar #'sort-names (copy-seq g)))
                groups)
        #'tree<=))
|#

promise.lisp

(defstruct promise flag result thunk)

(defmacro delay (expr) `(make-promise :thunk (lambda () ,expr)))

(defun force (x)
  (cond ((not (promise-p x)) x)
        ((promise-flag x)    (promise-result x))
        (t (setf (promise-flag   x) t
                 (promise-result x) (funcall (promise-thunk x))))))

trie.lisp

;;; trie by a-list

;; Just the six functions below depend on internal data structure.
;; Really you can use defstruct/hashtable rather than list-tuple/alist.
(defun make-trie-node (prefix val children)
  (list* prefix val children))
(defun trie-val        (trie)        (cadr trie))
(defun trie-set-val    (trie val)    (setf (cadr trie) val))
(defun trie-children   (trie)        (cddr trie))
(defun trie-add-child  (trie child)  (push child (cddr trie)))
(defun trie-find-child (trie prefix) (assoc prefix (cddr trie)))

(defun make-empty-trie ()
  (make-trie-node nil nil '()))

(defun make-singleton-trie (key val)
  (assert (consp key))
  (destructuring-bind (kar . kdr) (reverse key)
    (flet ((fn (acc x) (make-trie-node x nil (list acc))))
      (reduce #'fn kdr :initial-value (make-trie-node kar val '())))))

(defun search-trie-item (root-trie key)
  (assert (consp key))
  (labels ((si (trie prefixes)
             (if (null prefixes)
                 (values (trie-val trie) trie nil)
                 (let ((child (trie-find-child trie (car prefixes))))
                   (if child
                       (si child (cdr prefixes))
                       (values nil nil prefixes))))))
    (si root-trie key)))

(defun insert-trie-item (root-trie key item)
  (assert (consp key))
  (labels ((ii (trie prefixes)
             (if (null prefixes)
                 (let ((val (trie-val trie)))
                   (cond ((null val) (trie-set-val trie item))
                         ((eql val item))
                         (t          (warn "override ~s by ~s" val item)
                                     (trie-set-val trie item))))
                 (let ((child (trie-find-child trie (car prefixes))))
                   (if child
                       (ii child (cdr prefixes))
                       (trie-add-child trie
                                       (make-singleton-trie prefixes item)))))))
    (ii root-trie key)))

(defun make-trie-on (trie &rest data)
  (loop for (key . val) in data
        do  (insert-trie-item trie key val))
  trie)

#+:example
(defun decode (bits root)
  (let ((blen (length bits))
        (pool '()))
    (labels ((retval ()
               ;; better than concatenate after returning?
               (format nil "~{~a~}" (reverse pool)))
             (lp (trie bs)
               (if (null bs)
                   ;; have not encountered :END word
                   "*invalid*"
                   (destructuring-bind (b . rest-bs) bs
                     (multiple-value-bind (val next-trie)
                         ;; search per 1-bit
                         (search-trie-item trie (LIST B))
                       (cond ((eq val :END)
                              (values (retval) (- blen (length rest-bs))))
                             (val
                              (push val pool) (lp root rest-bs))
                             (t
                              (assert (null val))
                              (if next-trie
                                  (lp next-trie rest-bs)
                                  ;; not found in trie
                                  "*invalid*"))))))))
      (lp root bits))))

xconc.lisp

;; Sorry, but I don't know the APIs are compatible with the traditional ones.

(defun tconc-init ()
  ;; keep holding both list-head and last-cons
  (cons nil nil))

(defun tconc (que x)
  (let ((z (list x)))
    (cond ((equal que '(nil . nil))
           (rplaca que z)
           (rplacd que z))
          (t
           (rplacd (cdr que) z)
           (rplacd que z)))
    que))

(defun lconc-init ()
  ;; keep holding list-head and the last-cons to nconc
  (cons nil nil))

(defun lconc! (que xs)
  (cond ((equal que '(nil . nil))
         (rplaca que xs)
         (rplacd que (last xs)))
        (t
         (rplacd (cdr que) xs)
         (rplacd que (last xs))))
  que)

(defun lconc (que xs)
  (lconc! que (copy-list xs)))

;; usages

#|
(defun test-tconc (&aux (tc (tconc-init)))
  (loop for i from 1 to 10 do (tconc tc i))
  (car tc))

(defun test-lconc (&aux (lc (lconc-init)))
  (loop for i from 1 to 10 do (lconc lc (make-list i :initial-element i)))
  (car lc))
|#

;; something like tconc/lconc
(defun empty-q   (&aux (z (list nil)))   (cons z z)) ; add a dummy 1st item
(defun q-empty?  (q)                     (eq (car q) (cdr q)))
(defun q-content (q)                     (cdar q))   ; remove the 1st item
(defun q-head    (q)                     (cadar q))
(defun q-deque   (q)              (prog1 (cadar q) (setf (cdar q) (cddar q))))
;(defun q-enque   (q x &aux (z (list x))) (setf (cddr q) z (cdr q) z))
;(defun q-collect (q x &aux (z (list x))) (setf (cddr q) z (cdr q) z) q)
(defun q-enque   (q x &aux (z (list x))) (setf (cddr q) z (cdr q) z) q)
(defun q-collect (q x)                   (q-enque q x))
(defun q-nconc   (q z)                   (setf (cddr q) z (cdr q) (last z)) q)
(defun q-append  (q z)                   (q-nconc q (copy-seq z)))

#|
(defun test-tconc (&aux (q (empty-que)))
  (loop for i from 1 to 10 do (que-collect q i))
  (que-content q))

(defun test-lconc (&aux (q (empty-que)))
  (loop for i from 1 to 10 do (que-nconc q (make-list i :initial-element i)))
  (que-content q))
|#

#|
;;; mapcar/mapcan using empty-q, q-content, q-enque, q-nconc

(defun fmapcar (fn xs &aux (q (empty-q)))
  (labels ((rec (xs)
             (cond ((null xs) (q-content q))
                   (t         (q-enque q (funcall fn (car xs)))
                              (rec (cdr xs))))))
    (rec xs)))

(defun fmapcan (fn xs &aux (q (empty-q)))
  (labels ((rec (xs)
             (cond ((null xs) (q-content q))
                   (t         (q-nconc q (funcall fn (car xs)))
                              (rec (cdr xs))))))
    (rec xs)))
|#

xconc.scm

;; Sorry, but I don't know the APIs are compatible with the traditional ones.

;(define (last-pair xs)
;  (let ((next (cdr xs)))
;    (if (pair? next) (last-pair next) xs)))

;; keep holding list-head and last-cons
(define (tconc-init) (cons #f #f))
(define  lconc-init  tconc-init)

(define (tconc que x)
  (let ((z (list x)))
    (if (equal? que '(#f . #f))
	(set-car! que z)
	(set-cdr! (cdr que) z))
    (set-cdr! que z))
  que)

(define (lconc! que xs)
  (if (equal? que '(#f . #f))
      (set-car! que xs)
      (set-cdr! (cdr que) xs))
  (set-cdr! que (last-pair xs))
  que)

(define (lconc que xs) (lconc! que (list-copy xs)))

;; usages

#|
(define (test-tconc)
  (let ((tc (tconc-init)))
    (for-each (lambda (i) (tconc tc i))
	      '(1 2 3 4 5 6 7 8 9 10))
    (car tc)))

(define (test-lconc)
  (let ((lc (lconc-init)))
    (for-each (lambda (i) (lconc lc (make-list i i)))
	      '(1 2 3 4 5))
    (car lc)))
|#

xsequence.lisp

;;; cartesian product
(defun xsequence  (xss)
  (if (null xss)
      '(())
      (destructuring-bind (ys . zss) xss
        (mapcan (lambda (zs)
                  (mapcar (lambda (y) (cons y zs))
                          ys))
                (xsequence zss)))))

xtranspose.lisp

;; eXtended transpose -- using XMAPCAR/LISTIFY-... instead of MAPCAR/LIST
(defun xtranspose (xss)
  (apply #'XMAPCAR #'LISTIFY-W/O-ENDMARK xss))

;; eXtended mapcar -- using EVERY/CAR+/XMAPCAR instead of SOME/CAR/MAPCAR
(defun xmapcar (fn &rest xss)
  (if (EVERY #'null xss)
      '()
      (cons (apply fn (mapcar #'CAR+ xss))
            (apply #'XMAPCAR fn (mapcar #'cdr xss)))))

(defvar *end-mark* (cons nil nil))  ; any UNIQUE lisp object in terms of EQ

(defun car+ (x)
  (if (endp x) *end-mark* (car x)))

(defun listify-w/o-endmark (&rest xs)
  (remove *end-mark* xs :test #'eq))

#|
(defun split-lists (xss)
  ;; given a list of lists (xss), split it into
  ;; a list of the cars (kars) and a list of the cdrs (kdrs).
  (assert (not (null xss)))
  (flet ((analyze (x) (if (null x) (list nil '() t) (list (car x) (cdr x) nil))))
    (loop for xs in xss
          for (a d n?) = (analyze xs)
          collect a  into kars
          collect d  into kdrs
          collect n? into nulls?
          finally (return (values kars kdrs (every #'identity nulls?))))))

(defun xmapcar (fn &rest xss)
  (multiple-value-bind (kars kdrs all-null?) (split-lists xss)
    (if all-null?
        '()
        (cons (apply fn kars) (apply #'xmapcar fn kdrs)))))

(defun xtranspose (xss)
  ;; the local fn is somwhat tricky, i.e. it assumes
  ;;  - the difference among lengths of sequences is at most one.
  ;;  - longer sequences appear first.
  (flet ((fn (&rest xs) (loop for x in xs when x collect x)))
    (apply #'xmapcar #'fn xss)))

(defun transpose  (xss)
  (apply #'mapcar #'list xss))
|#