;
; Copyright © 2018 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.
;
; Advanced syntax, including vectors and floats

(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))
(equal? '(a b c) '(a b b))
(equal? #(1 2 3) #(1 2 3))
(equal? #(1 2 3) #(4 5 6))

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

      (cond ((pair? exp)
	     (eq? (car exp) 'quote)
	     )
	    (else
	     (not (symbol? exp))
	     )
	    )
      )

    (define (combine-skeletons 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)
	)
       )
      )

    (define (expand-quasiquote 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)
	     )
       )
      )
    (expand-quasiquote x 0)
    )
  )

					; `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)

					; 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))

(define assv assq)

(assv 'b '((a 1) (b 2) (c 3)))

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

(when #t (+ 1 2))
(when #f (+ 1 2))

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

(unless #f (+ 2 3))
(unless #t (+ 2 3))

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

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

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

(cddr '(1 2 3))

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

(caddr '(1 2 3 4))

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

(reverse '(1 2 3))

(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)

(make-list 10)

(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)
    )
  )

(let ((a 0))
  (for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
  a
  )
      
(call-with-current-continuation
       (lambda (exit)
	 (for-each (lambda (x)
		     (if (negative? x)
			 (exit x)))
		   '(54 0 37 -3 245 19))
	 #t))

(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 (list "the value is" x)))) (12 "twelve") (else "else"))
(case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))
(case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else"))
(case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))
(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))

(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))
     (y 0)
     )
    ((= x 10) y)
  (set! y (+ y x))
  )