;;; -*- purelisp -*-

(progn
  (load "init.lisp")
  (set 'r (lambda () (load "test.lisp")))
  ;; z = (t 0 1 2 ...)
  (set 'z (make-conseq t 'cardinals nil))
  ;; sq = (0 1 4 9 16 ...)
  (set 'sq (mapcar-lazy (lambda (x) (* x x)) cardinals))
  ;; nat = (0 1 ...)
  (set 'nat (make-conseq 0 '(mapcar-lazy (lambda (x) (+ x 1)) nat) nil))
  ;; nat0 = (0 1 ...)
  (set 'nat0 (make-conseq 0 '(apply-bin-op + nat0 ones) nil))

  (set 'nat1 (make-conseq 0 '(apply-seq + nat1 ones) nil))

  (set 'first-primes (lambda (N) (apply-bin-op (lambda (x y) y)
					       (gen-seq 0 N nil)
					       primes)))
;;  (print "primes")
;;  (mapcar print (first-primes 10))

  (set 'fib (lambda (a b)
	      (make-conseq 'a (omega '(fib b (+ a b))) nil)))

  (set 'fib11 (fib 1 1))
;;  (print "Fibonacci")
;;  (mapcar print (apply-bin-op (lambda (x y) y)
;;			      (gen-seq 0 10 nil)
;;			      fib11))


  (set 'compose
       (lambda (s1 s2)
	 (cond ((nilp s1) nil)
	       (t (make-conseq (omega '(nth (car s1) s2))
			       (omega '(compose (cdr s1) s2))
			       nil)))))
  (set 'print-first
       (lambda (n seq) (mapcar print (apply-bin-op (lambda (x y) y)
						   (gen-seq 0 n nil)
						   seq))))
  (set 'safe-print
       (lambda (obj n)
	 (let* ((map (make-map))
		(filled 0)
		(print-seq
		 (lambda (seq)
		   (let ((rest (cdr seq)))
		     (cond ((map-get map seq))
			   ((or (nilp seq) (= n 0)) "")
			   (t (progn (map-put map seq
					      (concat "#" (to-string filled)))
				     (set 'filled (+ filled 1))
				     (concat (actor (car seq))
					     (cond ((nilp rest) "")
						   ((atom? rest) " . ")
						   (t " "))
					     ((cond ((atom? rest) actor)
						    (t print-seq))
					      rest))))))))
		(actor (lambda (obj)
			 (set 'n (- n 1))
			 (cond ((= n 0) "...")
			       ((atom? obj) (to-string obj))
			       (t (concat "(" (print-seq obj) ")"))))))
	   (actor obj))))

  ;; non-recursive factorial
  (set 'f (lambda (n) ((lambda (fact) (fact fact n))
		       (lambda (ft k)
			 (cond ((= k 1) 1)
			       (t (* k (ft ft (- k 1)))))))))

  (set 'make-struct (lambda () (cons nil nil)))
  (set 'struct-get-field
       (lambda (struct field)
	 (car (filter struct (lambda (pair)
			       (cond ((eq (car pair) field) pair)))))))
  (set 'struct-get (lambda (struct field) (cdr (struct-get-field struct field))))
  (set 'struct-set (lambda (struct field val)
		     (let ((pair (struct-get-field struct field)))
		       (cond (pair (set-cdr pair val))
			     (t (progn (set-cdr struct (cons (car struct)
							     (cdr struct)))
				       (set-car struct (cons field val))))))))
  (set 'struct-del
       (lambda (struct field)
	 (cond ((nilp struct) nil)
	       ((eq (car (car struct)) field)
		(progn (set-car struct (car (cdr struct)))
		       (set-cdr struct (cdr (cdr struct)))))
	       (t (struct-del (cdr struct) field)))))
  (set 'struct-fields (lambda (struct) (mapcar car struct)))

  (set '*help-map* (make-map))

  (set 'help-field (lambda (symbol tag)
		     (struct-get (map-get *help-map* symbol) tag)))

  (set 'help (lambda (symbol)
	       (cond ((map-get *help-map* symbol)
		      (progn
			(message (concat " *** " (to-string symbol) " *** "))
			(message (concat "Type: " (help-field symbol 'type)))
			(message (help-field symbol 'desc))
			(message (concat "Eval: " (help-field symbol 'eval)))
			(message (concat "Apply: " (help-field symbol 'apply)))
			(cond ((not (nilp (help-field symbol 'ref)))
			       (progn
				 (message
				  (concat "References: "
					  (apply concat
						 (mapcar (lambda (o)
							   (concat
							    (to-string o)
							    " "))
							 (help-field symbol
								     'ref))))))))
			(message "")))
		     (t (message (concat "No help available on "
					 (to-string symbol)))))
	       nil))

  (set 'help-add (lambda (symbol tag (strings *rest*))
		   (let ((s (map-get *help-map* symbol)))
		     (cond ((nilp s) (progn (set 's (make-struct))
					    (map-put *help-map* symbol s))))
		     (struct-set s tag (apply concat strings)))))

  (help-add nil 'type "symbol")
  (help-add nil 'eval "self-evaluating")
  (help-add nil 'apply "not-a-function")
  (help-add nil 'desc
	    "Fundamental LISP object representing empty list "
	    "and false truth value")

  (help-add t 'type "symbol")
  (help-add t 'eval "self-evaluating")
  (help-add t 'apply "not-a-function")
  (help-add t 'desc "Fundamental LISP object representing truth value true")

  (help-add lambda 'type "symbol")
  (help-add lambda 'eval "self-evaluating")
  (help-add lambda 'apply
	    "Creates new lambda-function. "
	    "lambda-function is a LISP object that executes sequence "
	    "of actions described by arguments of lambda-form, when applied."
	    ""
	    "")
  (help-add lambda 'desc "Fundamental LISP object used to create new functions")
  (struct-set (map-get *help-map* lambda) 'ref '(apply eval))

  'ok-test)