;
; Copyright © 2016 Keith Packard <keithp@keithp.com>
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
; General Public License for more details.
;
; Lisp code placed in ROM

(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit)))))

					; return a list containing all of the arguments
(def (quote list) (lambda l l))

(def (quote def!)
     (macro (name value)
	    (list
	     def
	     (list quote name)
	     value)
	    )
     )

(begin
 (def! append
   (lambda args
	  (def! append-list
	    (lambda (a b)
	      (cond ((null? a) b)
		    (else (cons (car a) (append-list (cdr a) b)))
		    )
	      )
	    )
	    
	  (def! append-lists
	    (lambda (lists)
	      (cond ((null? lists) lists)
		    ((null? (cdr lists)) (car lists))
		    (else (append-list (car lists) (append-lists (cdr lists))))
		    )
	      )
	    )
	  (append-lists args)
	  )
   )
 'append)

(append '(a b c) '(d e f) '(g h i))

					; boolean operators

(begin
 (def! or
   (macro l
	  (def! _or
	    (lambda (l)
	      (cond ((null? l) #f)
		    ((null? (cdr l))
		     (car l))
		    (else
		     (list
		      cond
		      (list
		       (car l))
		      (list
		       'else
		       (_or (cdr l))
		       )
		      )
		     )
		    )
	      )
	    )
	  (_or l)))
 'or)

					; execute to resolve macros

(_?_ (or #f #t) #t)

(begin
 (def! and
   (macro l
	  (def! _and
	    (lambda (l)
	      (cond ((null? l) #t)
		    ((null? (cdr l))
		     (car l))
		    (else
		     (list
		      cond
		      (list
		       (car l)
		       (_and (cdr l))
		       )
		      )
		     )
		    )
	      )
	    )
	  (_and l)
	  )
   )
 'and)

					; execute to resolve macros

(_?_ (and #t #f) #f)

					; recursive equality

(begin
  (def! equal?
    (lambda (a b)
      (cond ((eq? a b) #t)
	    ((and (pair? a) (pair? b))
	     (and (equal? (car a) (car b))
		  (equal? (cdr a) (cdr b)))
	     )
	    ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
	     ((lambda (i l)
		(while (and (< i l)
			    (equal? (vector-ref a i)
				    (vector-ref b i)))
		       (set! i (+ i 1)))
		(eq? i l)
		)
	      0
	      (vector-length a)
	      )
	     )
	    (else #f)
	    )
      )
    )
  'equal?
  )

(_?_ (equal? '(a b c) '(a b c)) #t)
(_?_ (equal? '(a b c) '(a b b)) #f)
(_?_ (equal? #(1 2 3) #(1 2 3)) #t)
(_?_ (equal? #(1 2 3) #(4 5 6)) #f)

(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit)))))

(begin
 (def! quasiquote
   (macro (x)
	  (def! constant?
					; A constant value is either a pair starting with quote,
					; or anything which is neither a pair nor a symbol

	    (lambda (exp)
	      (cond ((pair? exp)
		     (eq? (car exp) 'quote)
		     )
		    (else
		     (not (symbol? exp))
		     )
		    )
	      )
	    )
	  (def! combine-skeletons
	    (lambda (left right exp)
	      (cond
	       ((and (constant? left) (constant? right)) 
		(cond ((and (eqv? (eval left) (car exp))
			    (eqv? (eval right) (cdr exp)))
		       (list 'quote exp)
		       )
		      (else
		       (list 'quote (cons (eval left) (eval right)))
		       )
		      )
		)
	       ((null? right)
		(list 'list left)
		)
	       ((and (pair? right) (eq? (car right) 'list))
		(cons 'list (cons left (cdr right)))
		)
	       (else
		(list 'cons left right)
		)
	       )
	      )
	    )

	  (def! expand-quasiquote
	    (lambda (exp nesting)
	      (cond

					; non cons -- constants
					; themselves, others are
					; quoted

	       ((not (pair? exp)) 
		(cond ((constant? exp)
		       exp
		       )
		      (else
		       (list 'quote exp)
		       )
		      )
		)

					; check for an unquote exp and
					; add the param unquoted

	       ((and (eq? (car exp) 'unquote) (= (length exp) 2))
		(cond ((= nesting 0)
		       (car (cdr exp))
		       )
		      (else
		       (combine-skeletons ''unquote 
					  (expand-quasiquote (cdr exp) (- nesting 1))
					  exp))
		      )
		)

					; nested quasi-quote --
					; construct the right
					; expression

	       ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
		(combine-skeletons ''quasiquote 
				   (expand-quasiquote (cdr exp) (+ nesting 1))
				   exp))

					; check for an
					; unquote-splicing member,
					; compute the expansion of the
					; value and append the rest of
					; the quasiquote result to it

	       ((and (pair? (car exp))
		     (eq? (car (car exp)) 'unquote-splicing)
		     (= (length (car exp)) 2))
		(cond ((= nesting 0)
		       (list 'append (car (cdr (car exp)))
			     (expand-quasiquote (cdr exp) nesting))
		       )
		      (else
		       (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
					  (expand-quasiquote (cdr exp) nesting)
					  exp))
		      )
		)

					; for other lists, just glue
					; the expansion of the first
					; element to the expansion of
					; the rest of the list

	       (else (combine-skeletons (expand-quasiquote (car exp) nesting)
					(expand-quasiquote (cdr exp) nesting)
					exp)
		     )
	       )
	      )
	    )
	  (def! result (expand-quasiquote x 0))
	  result
	  )
   )
 'quasiquote)

					;
					; Define a variable without returning the value
					; Useful when defining functions to avoid
					; having lots of output generated.
					;
					; Also accepts the alternate
					; form for defining lambdas of
					; (define (name x y z) sexprs ...) 
					;

(begin
 (def! define
   (macro (first . rest)
					; check for alternate lambda definition form

	  (cond ((pair? first)
		 (set! rest
		       (append
			(list
			 'lambda
			 (cdr first))
			rest))
		 (set! first (car first))
		 )
		(else
		 (set! rest (car rest))
		 )
		)
	  (def! result `(,begin
			 (,def (,quote ,first) ,rest)
			 (,quote ,first))
	    )
	  result
	  )
   )
 'define
 )

					; basic list accessors

(define (caar l) (car (car l)))

(_??_ (caar '((1 2 3) (4 5 6))) 1)

(define (cadr l) (car (cdr l)))

(_??_ (cadr '(1 2 3 4 5 6)) 2)

(define (cdar l) (cdr (car l)))

(_??_ (cdar '((1 2) (3 4))) '(2))

(define (cddr l) (cdr (cdr l)))

(_??_ (cddr '(1 2 3)) '(3))

(define (caddr l) (car (cdr (cdr l))))

(_??_ (caddr '(1 2 3 4)) 3)

					; (if <condition> <if-true>)
					; (if <condition> <if-true> <if-false)

(define if
  (macro (test . args)
	 (cond ((null? (cdr args))
		`(cond (,test ,(car args)))
		)
	       (else
		`(cond (,test ,(car args))
		       (else ,(cadr args)))
		)
	       )
	 )
  )

(_??_ (if (> 3 2) 'yes) 'yes)
(_??_ (if (> 3 2) 'yes 'no) 'yes)
(_??_ (if (> 2 3) 'no 'yes) 'yes)
(_??_ (if (> 2 3) 'no) #f)

					; simple math operators

(define zero? (macro (value) `(eq? ,value 0)))

(_??_ (zero? 1) #f)
(_??_ (zero? 0) #t)
(_??_ (zero? "hello") #f)

(define positive? (macro (value) `(> ,value 0)))

(_??_ (positive? 12) #t)
(_??_ (positive? -12) #f)

(define negative? (macro (value) `(< ,value 0)))

(_??_ (negative? 12) #f)
(_??_ (negative? -12) #t)

(define (abs x) (if (>= x 0) x (- x)))

(_??_ (abs 12) 12)
(_??_ (abs -12) 12)

(define max (lambda (first . rest)
		   (while (not (null? rest))
		     (cond ((< first (car rest))
			    (set! first (car rest)))
			   )
		     (set! rest (cdr rest))
		     )
		   first)
  )

(_??_ (max 1 2 3) 3)
(_??_ (max 3 2 1) 3)

(define min (lambda (first . rest)
		   (while (not (null? rest))
		     (cond ((> first (car rest))
			    (set! first (car rest)))
			   )
		     (set! rest (cdr rest))
		     )
		   first)
  )

(_??_ (min 1 2 3) 1)
(_??_ (min 3 2 1) 1)

(define (even? x) (zero? (% x 2)))

(_??_ (even? 2) #t)
(_??_ (even? -2) #t)
(_??_ (even? 3) #f)
(_??_ (even? -1) #f)

(define (odd? x) (not (even? x)))

(_??_ (odd? 2) #f)
(_??_ (odd? -2) #f)
(_??_ (odd? 3) #t)
(_??_ (odd? -1) #t)

(_??_ (list-tail '(1 2 3 . 4) 3) 4)

(define (list-ref x k)
  (car (list-tail x k))
  )

(_??_ (list-ref '(1 2 3 4) 3) 4)

(define (list-set! x k v)
  (set-car! (list-tail x k) v)
  x)

(list-set! (list 1 2 3) 1 4)

					; define a set of local
					; variables all at once and
					; then evaluate a list of
					; sexprs
					;
					; (let (var-defines) sexprs)
					;
					; where var-defines are either
					;
					; (name value)
					;
					; or
					;
					; (name)
					;
					; e.g.
					;
					; (let ((x 1) (y)) (set! y (+ x 1)) y)

(define let
  (macro (vars . exprs)
	 (define (make-names vars)
	   (cond ((not (null? vars))
		  (cons (car (car vars))
			(make-names (cdr vars))))
		 (else ())
		 )
	   )

					; the parameters to the lambda is a list
					; of nils of the right length

	 (define (make-vals vars)
	   (cond ((not (null? vars))
		  (cons (cond ((null? (cdr (car vars))) ())
			      (else
			       (car (cdr (car vars))))
			      )
			(make-vals (cdr vars))))
		 (else ())
		 )
	   )
					; prepend the set operations
					; to the expressions

					; build the lambda.

	 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
	 )
     )
		   

(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)

					; define a set of local
					; variables one at a time and
					; then evaluate a list of
					; sexprs
					;
					; (let* (var-defines) sexprs)
					;
					; where var-defines are either
					;
					; (name value)
					;
					; or
					;
					; (name)
					;
					; e.g.
					;
					; (let* ((x 1) (y)) (set! y (+ x 1)) y)

(define let*
  (macro (vars . exprs)

					;
					; make the list of names in the let
					;

	 (define (make-names vars)
	   (cond ((not (null? vars))
		  (cons (car (car vars))
			(make-names (cdr vars))))
		 (else ())
		 )
	   )

					; the set of expressions is
					; the list of set expressions
					; pre-pended to the
					; expressions to evaluate

	 (define (make-exprs vars exprs)
	   (cond ((null? vars) exprs)
		 (else
		  (cons
		   (list set
			 (list quote
			       (car (car vars))
			       )
			 (cond ((null? (cdr (car vars))) ())
			       (else (cadr (car vars))))
			 )
		   (make-exprs (cdr vars) exprs)
		   )
		  )
		 )
	   )

					; the parameters to the lambda is a list
					; of nils of the right length

	 (define (make-nils vars)
	   (cond ((null? vars) ())
		 (else (cons () (make-nils (cdr vars))))
		 )
	   )
					; build the lambda.

	 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
	 )
     )

(_??_ (let* ((x 1) (y x)) (+ x y)) 2)

(define when (macro (test . l) `(cond (,test ,@l))))

(_??_ (when #t (+ 1 2)) 3)
(_??_ (when #f (+ 1 2)) #f)

(define unless (macro (test . l) `(cond ((not ,test) ,@l))))

(_??_ (unless #f (+ 2 3)) 5)
(_??_ (unless #t (+ 2 3)) #f)

(define (reverse list)
  (define (_r old new)
    (if (null? old)
	new
	(_r (cdr old) (cons (car old) new))
	)
    )
  (_r list ())
  )

(_??_ (reverse '(1 2 3)) '(3 2 1))

(define make-list
  (lambda (a . b)
    (define (_m a x)
      (if (zero? a)
	  x
	  (_m (- a 1) (cons b x))
	  )
      )
    (if (null? b)
	(set! b #f)
	(set! b (car b))
	)
    (_m a '())
    )
  )
    
(_??_ (make-list 10 'a) '(a a a a a a a a a a))

(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))

(define member (lambda (obj list . test?)
		      (cond ((null? list)
			     #f
			     )
			    (else
			     (if (null? test?) (set! test? equal?) (set! test? (car test?)))
			     (if (test? obj (car list))
				 list
			       (member obj (cdr list) test?))
			     )
			    )
		      )
  )

(_??_ (member '(2) '((1) (2) (3)))  '((2) (3)))

(_??_ (member '(4) '((1) (2) (3))) #f)

(define (memq obj list) (member obj list eq?))

(_??_ (memq 2 '(1 2 3)) '(2 3))

(_??_ (memq 4 '(1 2 3)) #f)

(_??_ (memq '(2) '((1) (2) (3))) #f)

(define (memv obj list) (member obj list eqv?))

(_??_ (memv 2 '(1 2 3)) '(2 3))

(_??_ (memv 4 '(1 2 3)) #f)

(_??_ (memv '(2) '((1) (2) (3))) #f)

(define (assoc obj list . compare)
  (if (null? compare)
      (set! compare equal?)
      (set! compare (car compare))
      )
  (if (null? list)
      #f
    (if (compare obj (caar list))
	(car list)
	(assoc obj (cdr list) compare)
	)
    )
  )

(define (assq obj list) (assoc obj list eq?))
(define (assv obj list) (assoc obj list eqv?))

(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))

(define char? integer?)

(_??_ (char? #\q) #t)
(_??_ (char? "h") #f)

(define (char-upper-case? c) (<= #\A c #\Z))

(_??_ (char-upper-case? #\a) #f)
(_??_ (char-upper-case? #\B) #t)
(_??_ (char-upper-case? #\0) #f)
(_??_ (char-upper-case? #\space) #f)

(define (char-lower-case? c) (<= #\a c #\a))

(_??_ (char-lower-case? #\a) #t)
(_??_ (char-lower-case? #\B) #f)
(_??_ (char-lower-case? #\0) #f)
(_??_ (char-lower-case? #\space) #f)

(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))

(_??_ (char-alphabetic? #\a) #t)
(_??_ (char-alphabetic? #\B) #t)
(_??_ (char-alphabetic? #\0) #f)
(_??_ (char-alphabetic? #\space) #f)

(define (char-numeric? c) (<= #\0 c #\9))

(_??_ (char-numeric? #\a) #f)
(_??_ (char-numeric? #\B) #f)
(_??_ (char-numeric? #\0) #t)
(_??_ (char-numeric? #\space) #f)

(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))

(_??_ (char-whitespace? #\a) #f)
(_??_ (char-whitespace? #\B) #f)
(_??_ (char-whitespace? #\0) #f)
(_??_ (char-whitespace? #\space) #t)

(define char->integer (macro (v) v))
(define integer->char char->integer)

(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))

(_??_ (char-upcase #\a) #\A)
(_??_ (char-upcase #\B) #\B)
(_??_ (char-upcase #\0) #\0)
(_??_ (char-upcase #\space) #\space)

(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))

(_??_ (char-downcase #\a) #\a)
(_??_ (char-downcase #\B) #\b)
(_??_ (char-downcase #\0) #\0)
(_??_ (char-downcase #\space) #\space)

(define (digit-value c)
  (if (char-numeric? c)
      (- c #\0)
      #f)
  )

(_??_ (digit-value #\1) 1)
(_??_ (digit-value #\a) #f)

(define string (lambda chars (list->string chars)))

(_??_ (string #\a #\b #\c) "abc")

(_??_ (apply cons '(a b)) '(a . b))

(define map
  (lambda (proc . lists)
	 (define (_a lists)
	   (cond ((null? lists) ())
		 (else
		  (cons (caar lists) (_a (cdr lists)))
		  )
		 )
	   )
	 (define (_n lists)
	   (cond ((null? lists) ())
		 (else
		  (cons (cdr (car lists)) (_n (cdr lists)))
		  )
		 )
	   )
	 (define (_m lists)
	   (cond ((null? (car lists)) ())
		 (else
		  (cons (apply proc (_a lists)) (_m (_n lists)))
		  )
		 )
	   )
	 (_m lists)
	 )
  )

(_??_ (map cadr '((a b) (d e) (g h))) '(b e h))

(define for-each
  (lambda (proc . lists)
    (define (_f lists)
      (cond ((null? (car lists)) #t)
	    (else
	     (apply proc (map car lists))
	     (_f (map cdr lists))
	     )
	    )
      )
    (_f lists)
    )
  )

(for-each display '("hello" " " "world" "\n"))

(define (newline) (write-char #\newline))

(newline)

(call-with-current-continuation
 (lambda (exit)
   (for-each (lambda (x)
	       (write "test" x)
	       (if (negative? x)
		   (exit x)))
	     '(54 0 37 -3 245 19))
   #t))


					; `q -> (quote q)
					; `(q) -> (append (quote (q)))
					; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
					; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))



(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))


(define repeat
  (macro (count . rest)
	 (define counter '__count__)
	 (cond ((pair? count)
		(set! counter (car count))
		(set! count (cadr count))
		)
	       )
	 `(let ((,counter 0)
		(__max__ ,count)
		)
	    (while (< ,counter __max__)
	      ,@rest
	      (set! ,counter (+ ,counter 1))
	      )
	    )
	 )
  )

(repeat 2 (write 'hello))
(repeat (x 3) (write 'goodbye x))

(define case
  (macro (test . l)
					; construct the body of the
					; case, dealing with the
					; lambda version ( => lambda)

	 (define (_unarrow l)
	   (cond ((null? l) l)
		 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
		 (else l))
	   )

					; Build the case elements, which is
					; simply a list of cond clauses

	 (define (_case l)

	   (cond ((null? l) ())

					; else case

		 ((eq? (caar l) 'else)
		  `((else ,@(_unarrow (cdr (car l))))))

					; regular case
		 
		 (else
		  (cons
		   `((eqv? ,(caar l) __key__)
		     ,@(_unarrow (cdr (car l))))
		   (_case (cdr l)))
		  )
		 )
	   )

					; now construct the overall
					; expression, using a lambda
					; to hold the computed value
					; of the test expression

	 `((lambda (__key__)
	     (cond ,@(_case l))) ,test)
	 )
  )

(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "one")
(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "two")
(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x) "three")) (12 "twelve") (else "else")) "three")
(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "else")
(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) "twelve")

(define do
  (macro (vars test . cmds)
    (define (_step v)
      (if (null? v)
	  '()
	  (if (null? (cddr (car v)))
	      (_step (cdr v))
	      (cons `(set! ,(caar v) ,(caddr (car v)))
		    (_step (cdr v))
		    )
	      )
	  )
      )
    `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
       (while (not ,(car test))
	      ,@cmds
	      ,@(_step vars)
	      )
       ,@(cdr test)
       )
    )
  )

(do ((x 1 (+ x 1)))
    ((= x 10) "done")
  (display "x: ")
  (write x)
  (newline)
  )

(_??_ (do ((vec (make-vector 5))
	   (i 0 (+ i 1)))
	  ((= i 5) vec)
	(vector-set! vec i i)) #(0 1 2 3 4))