Playing with List Comprehensions in CL

;; List comprehensions for Common Lisp, from: 
;;   http://blog.superadditive.com/2007/11/09/list-comprehensions-in-common-lisp/
;;   http://superadditive.com/projects/incf-cl/

;; To install in most modern Lisps (I'm using sbcl):
;;   (require 'asdf-install)
;;   (asdf-install:install "http://superadditive.com/software/incf-cl.tar.gz")

;; load the library
(require :incf-cl)

;; import it's exported symbols
(use-package :incf-cl)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; generate ranges of numbers:

(range 1 10)
;; => (1 2 3 4 5 6 7 8 9 10)

;; even using ratio steps
(range 0 1/4 2) 
;; => (0 1/4 1/2 3/4 1 5/4 3/2 7/4 2)

;; they don't have to line up:
(range 0 2/3 3)
;; => (0 2/3 4/3 2 8/3)

(range 0 0.325 2.5)
;; => (0 0.325 0.65 0.97499996 1.3 1.625 1.95 2.275)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Now for the list comprehensions, the first examples are from the
;; documentation.

;; - the initial form is an action to apply to each generated item

;; - the (<- x things) form means take each x from things
;;   note that multiple takes are permutative...

;; - all other forms are predicates which are anded together

(assemble (cons x y) (<- x (range 0 2)) (<- y (range 0 2)) (= 2 (+ x y)))
;; => ((0 . 2) (1 . 1) (2 . 0))

;; compare to two nested loops:
(loop
 for x from 0 to 2
 with res = (list)
 finally (return res)
 do
 (loop
  for y from 0 to 2
  do
  (when (= 2 (+ x y))
    (push (cons x y) res))))
;; => ((2 . 0) (1 . 1) (0 . 2))

;; hrm...that's kinda noisy / inelegant, but this is only slighly less
;; verbose (someone with more lisp can probalby do better):
(let ((res (list)))
  (loop for x from 0 to 2
	do
	(loop for y from 0 to 2
	      do
	      (when (= 2 (+ x y))
		(push (cons x y) res))))
  res)
;; => ((2 . 0) (1 . 1) (0 . 2))

;; point is, the list comprehension is much more declarative, much
;; clearer in intent (which is the point afterall)

;; filter for odd numbers:
(assemble x (<- x (range 0 10)) (oddp x))
;; => (1 3 5 7 9)

;; compare that to the remove-if-not form:
(remove-if-not #'oddp (range 0 10))
;; => (1 3 5 7 9)

;; divisble by 3:
(assemble x (<- x (range 0 20)) (= 0 (mod x 3)))
;; => (0 3 6 9 12 15 18)

;; comparatively the remove-if-not form:
(remove-if-not #'(lambda (nn) (= 0 (mod nn 3))) (range 0 20))
;; => (0 3 6 9 12 15 18)

;; Project Euler #6 (inelegant) using list comprehensions to make the
;; 'sum of squares'
(-
 (* (apply #'+ (range 1 100))
    (apply #'+ (range 1 100)))
 (apply #'+ (assemble (* x x) (<- x (range 1 100)))))

;; let's see how it compares to a loop
(defmacro benchmark (times &rest body)
  (let ((ctr (gensym)))
    `(time
      (loop for ,ctr from 1 to ,times
       do
       ,@body))))

;; this should be hard to beat...
(benchmark 
 100000
 (loop for x from 1 to 100
       summing (* x x)))

;; Evaluation took:
;;   0.09 seconds of real time
;;   0.092006 seconds of user run time
;;   0.0 seconds of system run time
;;   0 calls to %EVAL
;;   0 page faults and
;;   0 bytes consed.

(benchmark
 100000
 (let ((max 100))
   (declare (type fixnum max))
   (labels ((lp (acc next)
	      (declare (type fixnum acc next))
	      (if (> next max)
		  acc
		  (lp (+ acc (* next next)) (1+ next)))))
     (lp 0 1))))

;; Evaluation took:
;;   0.184 seconds of real time
;;   0.176011 seconds of user run time
;;   0.0 seconds of system run time
;;   0 calls to %EVAL
;;   0 page faults and
;;   0 bytes consed.

(benchmark
 100000
 (apply #'+ (assemble (* x x) (<- x (range 1 100)))))

;; Evaluation took:
;;   1.494 seconds of real time
;;   1.43609 seconds of user run time
;;   0.016001 seconds of system run time
;;   [Run times include 0.188 seconds GC run time.]
;;   0 calls to %EVAL
;;   0 page faults and
;;   242,399,064 bytes consed.

;; wow, look at all those bytes consed!  hrm, but that also times
;; the function range, so lets factor that out...
(let ((nums (range 1 100)))
  (benchmark
   100000
   (apply #'+ (assemble (* x x) (<- x nums)))))

;; Evaluation took:
;;   1.145 seconds of real time
;;   0.916057 seconds of user run time
;;   0.0 seconds of system run time
;;   [Run times include 0.144 seconds GC run time.]
;;   0 calls to %EVAL
;;   0 page faults and
;;   161,593,152 bytes consed.

(benchmark 100000 (loop for x from 1 to 1000 summing (* x x)))
;; 0.904s
(let ((nums (range 1 100))) (benchmark 100000 (apply #'+ (assemble (* x x) (<- x nums)))))
;; vs 0.956s nearly identical...which is nice since assemble builds a
;; list to be passed on to apply


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; More list comprehension examples from:
;;
;; http://web.mit.edu/erlang_vR10B-10/arch/sun4x_510/lib/erlang/doc/programming_examples/list_comprehensions.html

;; Using list comprehensions this is nicely succinct, kinda cool.
(defun pythagorean-triplets (nn)
  "All the pythagorean triplets of A,B,C where C is the hypotenuse, A
and B are the other sides of a right triangle, and A+B+C is <= NN.

Using list comprehensions this basically says, take A from the numbers
1..N (same for B and C), where A+B+C is <= NN and A^2+B^2=C^2.
"
  (assemble (list a b c)
    (<- a (range 1 nn))
    (<- b (range 1 nn))
    (<- c (range 1 nn))
    (<= (+ a b c) nn)
    (= (* c c) (+ (* a a) (* b b)))))

(pythagorean-triplets 3)
;; => NIL

(pythagorean-triplets 11)
;; => NIL

(pythagorean-triplets 12)
;; => ((3 4 5) (4 3 5))

(pythagorean-triplets 50)
;; => ((3 4 5) (4 3 5) (5 12 13) (6 8 10) (8 6 10) (8 15 17) (9 12 15) (12 5 13)
;;     (12 9 15) (12 16 20) (15 8 17) (16 12 20))

(pythagorean-triplets 50)


;; just for reference, Lisp does support list (actually tree)
;; destructuring kind of like what see in Erlang, Haskell and OCaml.
;; One caveat is that destructuring-bind doesn't do matching, just
;; destructuring.  See: http://www.cliki.net/pattern%20matching and
;; http://www.cliki.net/fare-matcher for fuller CL support for pattern
;; matching of that kind.
;;
;;  [H|T] can be written with destructuring-bind:
(destructuring-bind (hd . tl) '(a b c)
  (list hd tl))
;; one thing to note is that T is true in lisp, so you can't use it as
;; a symbol (unless you're using a case sensitive Lisp, which most are
;; not, at least by default)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; quick sort using comprehensions
(defun lcmp-qsort (things)
  "Quick Sort: using the first element of the list as a pivot, create
a new list by appending together:

 - the qsort of all the elements less than the Pivot
 - the Pivot
 - the qsort of all the elements greater than or equal to the Pivot

"
  (declare (optimize (speed 3) (safety 0)))
  (cond ((null things)
	 things)
	(t
	 (destructuring-bind (pivot . tl) things
	   (append
	    (lcmp-qsort
	     (assemble x (<- x tl) (< x pivot)))
	    (list pivot)
	    (lcmp-qsort
	     (assemble x (<- x tl) (>= x pivot))))))))

(lcmp-qsort '())
;; => NIL

(lcmp-qsort '(3 1 2 7 8 9 6 0 4 5))
;; => (0 1 2 3 4 5 6 7 8 9)

(benchmark 
 1000
 (let ((rand-nums (loop for ii from 1 to 1000 collect (random 1.0))))
   (lcmp-qsort rand-nums)))
;; 1.858

(benchmark
 1000
 (let ((rand-nums (loop for ii from 1 to 1000 collect (random 1.0))))
   (sort rand-nums #'<)))
;; 1.177


;; When I first saw all-permutations as a list comprehension in Erlang
;; and Haskell I was taken aback at it's elegance - it was very
;; unlikely to contain any kind of bug due to its declarative nature.
(defun all-permutations (things)
  "All the permutations of the items in the list (careful, this is N!
and will be prohibitively, horribly, teriibly expensive for large
lists).

  - the permutations of a single thing is a list of that thing
  - otherwise its each element (H) of the list prepented onto every
    permutation of the elements with H removed.
"
  (cond 
    ((= 1 (length things))
     (list things))
    (t
     (assemble
	 (cons Head Tail)
       (<- Head things)
       (<- Tail (all-permutations (remove Head things)))))))

(all-permutations '())
;; => NIL

(all-permutations '(a b))
;; => ((A B) (B A))

(all-permutations '(a b c))
;; => ((A B C) (A C B) (B A C) (B C A) (C A B) (C B A))


;; append as a comprehension
(defun lcmp-append (&rest lists)
  (assemble x (<- l1 lists) (<- x l1)))

(lcmp-append '(a b c) '(d e f) '(g h i))
;; => (A B C D E F G H I)

;; map (car) as a comprehension
(defun lcmp-map (fn things)
  (assemble
      (funcall fn x)
    (<- x things)))

(lcmp-map #'1+ '(1 2 3))
;; => (2 3 4)

;; filter as a comprehension
(defun lcmp-filter (pred things)
  (assemble
      x
    (<- x things)
    (funcall pred x)))

(lcmp-filter #'oddp (range 1 20))
;; => (1 3 5 7 9 11 13 15 17 19)