;;; euphemisms ------------------------------------------ #

(define exit quit)
(define bye quit)

(define car first)
(define cdr rest)

(define write print)
(define display (lambda (item)
  (if (string? item)
      (print (string->symbol item))
      (print item) ) ))


;;; useful scheme features ------------------------------ #

(define compose (lambda (f g)
  (lambda (x)
    (f (g x)) ) ))

(define writeln (lambda args
  (for-each display args)
  (newline) ))

(define error (lambda args
  (display "ERROR: ")
  (for-each display args)
  (newline) ))


;;; nested car / cdr combos ----------------------------- #

(define caar (lambda (x)
  (car (car x)) ))
(define cadr (lambda (x)
  (car (cdr x)) ))
(define cdar (lambda (x)
  (cdr (car x)) ))
(define cddr (lambda (x)
  (cdr (cdr x)) ))

(define caaar (lambda (x)
  (car (caar x)) ))
(define caadr (lambda (x)
  (car (cadr x)) ))
(define cadar (lambda (x)
  (car (cdar x)) ))
(define caddr (lambda (x)
  (car (cddr x)) ))
(define cdaar (lambda (x)
  (cdr (caar x)) ))
(define cdadr (lambda (x)
  (cdr (cadr x)) ))
(define cddar (lambda (x)
  (cdr (cdar x)) ))
(define cdddr (lambda (x)
  (cdr (cddr x)) ))

(define caaaar (lambda (x)
  (car (caaar x)) ))
(define caaadr (lambda (x)
  (car (caadr x)) ))
(define caadar (lambda (x)
  (car (cadar x)) ))
(define caaddr (lambda (x)
  (car (caddr x)) ))
(define cadaar (lambda (x)
  (car (cdaar x)) ))
(define cadadr (lambda (x)
  (car (cdadr x)) ))
(define caddar (lambda (x)
  (car (cddar x)) ))
(define cadddr (lambda (x)
  (car (cdddr x)) ))
(define cdaaar (lambda (x)
  (cdr (caaar x)) ))
(define cdaadr (lambda (x)
  (cdr (caadr x)) ))
(define cdadar (lambda (x)
  (cdr (cadar x)) ))
(define cdaddr (lambda (x)
  (cdr (caddr x)) ))
(define cddaar (lambda (x)
  (cdr (cdaar x)) ))
(define cddadr (lambda (x)
  (cdr (cdadr x)) ))
(define cdddar (lambda (x)
  (cdr (cddar x)) ))
(define cddddr (lambda (x)
  (cdr (cdddr x)) ))


;;; logic: syntactic sugar ------------------------------ #

(define not (lambda (arg)
; arg: (boolean-expression)
; simple logical negation

  (if arg #f #t) ))

(define and (macro args
; args: (boolean-expression boolean-expression ... )
; simple logical conjunction
; but using short-circuit implementation

  (if (null? args)
      #t
      `(if ,(car args)
           (and ,@(cdr args))
           #f ) ) ))

(define or (macro args
; args: (boolean-expression boolean-expression ... )
; simple logical disjunction
; but using short-circuit implementation

  (if (null? args)
      #f
      `(if ,(car args)
           #t
           (or ,@(cdr args)) ) ) ))

;; ------------------------------------------------------ #

(define when (macro args
; args: (boolean-test body)
; body: statement1 statement2 ...
; if boolean-test is true, then execute body

  `(if ,(car args) (begin ,@(cdr args)) ()) ))

(define unless (macro args
; args: (boolean-test body)
; body: statement1 statement2 ...
; if boolean-test is false, then execute body

  `(if ,(car args) () (begin ,@(cdr args))) ))

;; ------------------------------------------------------ #

(define cond (macro args
; args: ((test1 body1) (test2 body2) ... )
; testi: boolean expression
; body: statement1 statement2 ...
; if testi is true, then execute bodyi
;    else move on to next (test body) pair

  (if (null? (car args))
      '()
      `(if ,(caar args)
           (begin ,@(cdar args))
           (cond ,@(cdr args)) ) ) ))

(define while (macro args
; args: (test body)
; test: boolean-expression
; body: statement1 statement2 ...
; while the boolean-test evaluates to true
;    execute the body of the loop
; this is a top-tested loop!

  `(when ,(car args) (begin ,@(cdr args) (while ,@args))) ))

(define until (macro args
; args: (test body)
; test: boolean-expression
; body: statement1 statement2 ...
; until the boolean-test evaluates to true
;    execute the body of the loop
; this is a bottom-tested loop!

  `(begin ,@(cdr args) (unless ,(car args) (until ,@args))) ))


;;; set-car! and set-cdr!: syntactic sugar -------------- #
; basic mutators for dotted pairs

(define set-car! (macro (p x)
; replaces (car p) with item x
  `(set! ,p (cons ,x (cdr ,p))) ))

(define set-cdr! (macro (p x)
; replaces (cdr p) with item x
  `(set! ,p (cons (car ,p) ,x)) ))


;;; let: syntactic sugar -------------------------------- #

(define let (macro args
; args: list-pairs body
; list-pairs: ((symbol1 expression1) (symbol2 expression2) ... )
; body: statement1 statement2 ...

; NOTE: expressions in let are limited to symbols
;     from the CURRENT environment!
; no reference is permitted to a previously defined symbol
;     in the NEW let environment

  `((lambda ,(get-cars (car args)) ,@(cdr args))
    ,@(get-cdrs (car args)) ) ))

(define get-cars (lambda (args)
; args: ((symbol1 expression1) (symbol2 expression2) ... )

  (if (null? args)
      '()
      (cons (caar args) (get-cars (cdr args))) ) ))

(define get-cdrs (lambda (args)
; args: ((symbol1 expression1) (symbol2 expression2) ... )

  (if (null? args)
      '()
      (cons (cadar args) (get-cdrs (cdr args))) ) ))


;;; let*: syntactic sugar ------------------------------- #

(define let* (macro args
; args: list-pairs body
; list-pairs: ((symbol1 expression1) (symbol2 expression2) ... )
; body: statement1 statement2 ...

; NOTE: expressions in let* are no longer limited to symbols
;     from the CURRENT environment!
; references are permitted to a previously defined symbol
;     in the NEW let environment

  (if (null? (car args))
      `(let () ,@(cdr args))
      `(let (,(caar args)) (let* ,(cdar args) ,@(cdr args))) ) ))


;;; letrec: syntactic sugar ----------------------------- #

(define letrec (macro args
; args: list-pairs body
; list-pairs: ((symbol1 expression1) (symbol2 expression2) ... )
; body: statement1 statement2 ...

; NOTE: expressions in letrec are typically lambda forms!
;     i.e., the let args define functions
; if we intend for these function to recursively interact with one another
;     a simple let statement will not work (due to scope limitations!)
; the letrec statement gets around this limitation

  (if (null? (car args))
      `(let () ,@(cdr args))
      (begin
        (define no-symbols (length (car args)))
        (define symbol-list (get-cars (car args)))
        (define value-list (get-cdrs (car args)))
        (define temp-list (create-list no-symbols))
        (define undefined-list (create-list no-symbols "na"))
        (define undefined-evals (create-let-pairs symbol-list undefined-list))
        (define temp-evals (create-let-pairs temp-list value-list))
        (define official-evals (create-set-pairs symbol-list temp-list))
        `(let (,@undefined-evals) (let (,@temp-evals) ,@official-evals ,@(cdr args))) ) ) ))
end

(define create-list (lambda args
; args (no-items value)
; creates a new list containing the specified value repeated no-items
; if value is not specified, then use gensym to generate unique values

  (if (= (car args) 0)
      '()
      (if (null? (cdr args))
          `(,(gensym) ,@(create-list (- (car args) 1)))
          `(,(cadr args) ,@(create-list (- (car args) 1) (cadr args))) ) ) ))

(define create-let-pairs (lambda (symbol-list value-list)
; args: (symbol-list value-list)
; creates a new list containing pairs of corresponding values from each list
; both list must have the same length!

  (if (= (length symbol-list) (length value-list))
      (if (null? symbol-list)
          '()
          `((,(car symbol-list) ,(car value-list))
            ,@(create-let-pairs (cdr symbol-list) (cdr value-list)) ) )
      "length mismatch" ) ))

(define create-set-pairs (lambda (symbol-list temp-list)
; args: (symbol-list temp-list)

  (if (= (length symbol-list) (length temp-list))
      (if (null? symbol-list)
          '()
          `((set! ,(car symbol-list) ,(car temp-list))
                ,@(create-set-pairs (cdr symbol-list) (cdr temp-list)) ) )
      "length mismatch" ) ))


;;; ----------------------------------------------------- #

(load "numbers.scm")
(load "lists.scm")
(load "streams.scm")

;;; ----------------------------------------------------- #