;;; -*- purelisp -*-

(progn

(message "Basic definitions...")

(set 'defun (lambda ((name *lazy*) (args *lazy*) (body *rest* *lazy*))
	      (set name (apply lambda (cons args body)))))

;; fix-point combinator
(defun Y-classical (f) ((lambda (x) (f (x x))) (lambda (y) (f (y y)))))

;; identity function
(defun id (a) a)

;; factorial
(defun factorial (n) (cond ((= n 0) 1) (t (* n (factorial (- n 1))))))

;; "The Ackermann Function"
(defun ackermann (m n)
  (cond ((= m 0) (+ n 1))
	((= n 0) (ackermann (- m 1) 1))
	(t (ackermann (- m 1) (ackermann m (- n 1))))))

(defun append-list (list)
  (cond ((nilp list) nil)
	(t (let* ((append2 (lambda (s1 s2)
			     (cond ((nilp s1) s2)
				   (t (cons (car s1)
					    (append2 (cdr s1) s2)))))))
	     (append2 (car list) (append-list (cdr list)))))))

(defun append ((list *rest*)) (append-list list))

(defun length (seq) (cond ((nilp seq) 0)
			  (t (+ 1 (length (cdr seq))))))

(defun mapc (f seq)
  (cond ((nilp seq) nil)
	(t (progn (f (car seq)) (mapc f (cdr seq)) seq)))) ; return value of
							   ; mapc is SEQ

(defun mapcar (f seq)
  (cond ((nilp seq) nil)
	(t (cons (f (car seq)) (mapcar f (cdr seq))))))

;; return LISP object whose evaluation will result in evaluation of SEXP
;; NOTE: OMEGA is plain function, so SEXP should usually be quoted
(defun omega (sexp)
  (let ((dyn (env-dynamic (env-parent (env)))))
    (list (lambda () (eval-in dyn sexp)))))

;; return lazy sequence (start, start + 1, ... end - 1) (possibly infinite
;; if END cannot be reached
(defun gen-seq (start end base)
  (make-conseq (omega 'start)
	       (omega '(cond
			((eq start end) nil)
			(t (gen-seq (+ start 1) end base))))
	       base))

(defun nth (n seq)
  (cond ((= 0 n) (car seq))
	(t (nth (- n 1) (cdr seq)))))

(defun elt (seq n) (nth n seq))

(defun filter (seq pred)
  (cond ((nilp seq) nil)
	(t (let ((rest (filter (cdr seq) pred))
		 (head (car seq)))
	     (cond ((pred head) (cons head rest))
		   (t rest))))))

;; call-by-need thunk
(defun make-thunk (sexp)
  (let ((dyn (env-dynamic (env-parent (env)))))
    (lambda ()
      (let ((val nil) (runme t))
	(cond (runme (progn (set 'val (eval-in dyn sexp))
			    (set 'runme nil))))
	val))))

(defun gen-inf-seq-n (gen n start)
  (let ((cur (gen n start)))
    (make-conseq (omega 'cur)
		 (omega '(gen-inf-seq-n gen (+ n 1) cur))
		 nil)))

;; generate sequence a_0 = (gen 0 start), a_n = (gen n a_{n - 1})
(defun gen-inf-seq (gen start) (gen-inf-seq-n gen 0 start))

;; cardinals = (0 1 ...)
(set 'cardinals (gen-inf-seq (lambda (n prev) n) 0))

;; ones = (1 1 ...)
(set 'ones (gen-inf-seq (lambda (n prev) 1) 0))

;; MAPCAR for lazy sequences
(defun mapcar-lazy (f seq)
  (cond ((nilp seq) nil)
	(t (make-conseq (omega '(f (car seq)))
			(omega '(mapcar-lazy f (cdr seq)))
			nil))))

;; return lazy sequence consisting of members of SEQ satisfying PRED
(defun filter-lazy (seq pred)
  (let* ((find-next (lambda (c) (cond ((nilp c) nil)
				      ((pred (car c)) c)
				      (t (find-next (cdr c))))))
	 (search t))
    (make-conseq (omega '(progn
			  (cond (search (progn (set 'seq (find-next seq))
					       (set 'search nil))))
			  (car seq)))
		 (omega '(filter-lazy (find-next (cdr seq)) pred))
		 nil)))

(defun apply-bin-op (f s1 s2)
  (cond ((nilp s1) nil)
	(t (make-conseq (omega '(f (car s1) (car s2)))
			(omega '(apply-bin-op f (cdr s1) (cdr s2)))
			nil))))

;; apply F to the list of possibly lazy sequences
(defun apply-list-seq (f seq)
  (cond ((nilp seq) nil)
	(t (make-conseq (omega '(apply f (mapcar car seq)))
			(omega '(apply-list-seq f
				 (mapcar cdr seq)))
			nil))))

;; apply F to the (possibly lazy) sequences
(defun apply-seq (f (seq *rest*)) (apply-list-seq f seq))

(defun mod (p q) (- p (* (/ p q) q)))
(defun dividesp (p q) (= 0 (mod q p)))
(defun primep (n) (let ((check-divisors
			 (lambda (n m)
			   (cond ((> (* m m) n) nil)
				 (t (or (dividesp m n)
					(check-divisors n (+ m 1))))))))
		    (not (check-divisors n 2))))

;; sequence of primes (starting from 0, hehe)
(set 'primes (filter-lazy cardinals primep))

;; like OMEGA, but SEXP is evaluated at most once
(defun omega-once (sexp)
  (let ((dyn (env-dynamic (env-parent (env))))
	(val nil)
	(run t))
    (list (lambda () (cond (run (set 'val (eval-in dyn sexp)))) val))))

;; "stabilize" a CONSEQ so that its car and cdr produce the same values when
;; called repeatedly.
(defun make-stable-conseq (conseq)
  (cond ((nilp conseq) nil)
	(t (make-conseq
	    (omega-once '(car conseq))
	    (omega-once '(make-stable-conseq (cdr conseq)))
	    nil))))

;; enumeration of CARDINALS * CARDINALS
(set 'cartesian-0
     (make-stable-conseq
      (let ((do-pair
	     (lambda (x y) (make-conseq
			    (omega '(cons x y))
			    (omega '(cond
				     ((> y 0) (do-pair (+ x 1) (- y 1)))
				     (t (do-pair 0 (+ x 1)))))
			    nil))))
	(do-pair 0 0))))
;; Cartesian product of two sequences
(defun cartesian-product (s1 s2)
  (mapcar-lazy (lambda (xy) (cons (nth (car xy) s1)
				  (nth (cdr xy) s2)))
	       cartesian-0))

(message "Arrow-LISP library (http://t3x.dyndns.org/LISP/CL/index.html)...")
;; TODO: http://t3x.dyndns.org/LISP/CL/index.html

;; Verify that at least one member of a list has a given property. Return
;; *T*, if a member with the given property exists and otherwise *F*.
(defun any (x p)
  (cond ((nilp x) nil)
	((p (car x)) t)
	(t (any (cdr x) p))))

;; Retrieve a binding from an association list. An association list is a
;; list of pairs where the CAR part of each pair holds a key and the CDR
;; part of the pair holds the value associated with that key:
;;
;; ((key1 . value1) ... (keyN . valueN))
(defun assoc (x a)
  (cond ((nilp a) nil)
	((eq (caar a) x) (car a))
	(t (assoc x (cdr a)))))

(defun caar (x) (car (car x)))
(defun cadr (x) (car (cdr x)))
(defun cdar (x) (cdr (car x)))
(defun cddr (x) (cdr (cdr x)))

(defun caaar (x) (car (car (car x))))
(defun caadr (x) (car (car (cdr x))))
(defun cadar (x) (car (cdr (car x))))
(defun caddr (x) (car (cdr (cdr x))))
(defun cdaar (x) (cdr (car (car x))))
(defun cdadr (x) (cdr (car (cdr x))))
(defun cddar (x) (cdr (cdr (car x))))
(defun cdddr (x) (cdr (cdr (cdr x))))

(defun caaaar (x) (car (car (car (car x)))))
(defun caaadr (x) (car (car (car (cdr x)))))
(defun caadar (x) (car (car (cdr (car x)))))
(defun caaddr (x) (car (car (cdr (cdr x)))))
(defun cadaar (x) (car (cdr (car (car x)))))
(defun cadadr (x) (car (cdr (car (cdr x)))))
(defun caddar (x) (car (cdr (cdr (car x)))))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun cdaaar (x) (cdr (car (car (car x)))))
(defun cdaadr (x) (cdr (car (car (cdr x)))))
(defun cdadar (x) (cdr (car (cdr (car x)))))
(defun cdaddr (x) (cdr (car (cdr (cdr x)))))
(defun cddaar (x) (cdr (cdr (car (car x)))))
(defun cddadr (x) (cdr (cdr (car (cdr x)))))
(defun cdddar (x) (cdr (cdr (cdr (car x)))))
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))))

;; Copy an S-expression. Of course, this function is never required in pure
;; LISP programs, since lists are never altered. This function serves as a
;; model for other functions that have to traverse list or tree structures.
(defun copy (x)
  (cond ((atom? x) x)
        (t (cons (copy (car x)) (copy (cdr x))))))

;; Recursively count the atoms of a list. Members of all sublists are
;; included. For instance,
;;
;; (COUNT '(1 (2 (3)))) => 3
(defun count (x)
    (cond ((nilp x) 0)
	  ((atom? x) 1)
	  (t (+ (count (car x)) (count (cdr x))))))

;; Compute the depth of a list. The depth of a list is the maximum number of
;; nested lists enclosing any atom of the list. The depth of an atom is 0.
(defun depth (a)
  (cond ((atom? a) 0)
        (t (+ (max (mapcar depth a)) 1))))

;; Find the maximum of a set/list.
(defun max-list (a)
    (cond ((nilp (cdr a)) (car a))
	  ((> (car a) (cadr a)) (max-list (cons (car a) (cddr a))))
	  (t (max-list (cdr a)))))

(defun max ((a *rest*)) (max-list a))

;; Extract the last member of a list.
(defun last (x) (car (reverse x)))

;; Reduce a list. Combine the first member of the list with the reduced rest
;; of the list using a given function.
(defun reduce (a x f)
  (cond ((nilp a) x)
        (t (f (car a) (reduce (cdr a) x f)))))

;; Reverse the order of members of a list.
(defun reverse (a)
  (cond ((nilp a) a)
        (t (append (reverse (cdr a)) (list (car a))))))

;; Substitute variables in S-expressions. For a description of association
;; lists (alists) see ASSOC.
(defun sublis (a x)
    (cond ((nilp x) nil)
	  ((atom? x) (cond ((nilp (assoc x a)) x)
			   (t (cdr (assoc x a)))))
	  (t (cons (sublis a (car x)) (sublis a (cdr x))))))

;; Compute the union of two sets. Sets are represented by lists of unique
;; members.
(defun union (a b)
  (cond ((nilp a) b)
        ((member (car a) b) (union (cdr a) b))
        (t (cons (car a) (union (cdr a) b)))))

;; Transform a list into a set (a list containing only unique elements).
(defun unique (a)
  (cond ((nilp a) a)
        ((member (car a) (cdr a)) (unique (cdr a)))
        (t (cons (car a) (unique (cdr a))))))

(defun member (x a)
  (cond ((nilp a) nil)
        ((eq (car a) x) t)
        (t (member x (cdr a)))))

;; Compute the intersection of two sets. Sets are represented by lists of
;; unique members.
(defun intersection (a b)
    (cond ((nilp a) nil)
	  ((member (car a) b) (cons (car a) (intersection (cdr a) b)))
	  (t (intersection (cdr a) b))))

;; Remove members from lists
(defun remove (a p) (filter a (lambda (x) (not (p x)))))

'ok)