;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
;; implements now 15 Lisp functions such as null?, 1st, 2nd, 3rd, rst,
;; cons, atom?, is?, +, -, *, /, >, < and fn as primitives.
;; Version.1.3 has three special operators, if, = and def, which are all
;; inspired by Paul Graham's Arc. = is setf of CL. def is defun of CL.
;; Renamed some operators, because I like schemers' way better.
;; Now Small-Lisp has a file-loading function, slisp-load, then it can
;; load and evaluate some function-definition files, that define non-primitive
;; functions defined in Small-Lisp style. "slisp.slisp" provides some functions
;; such as car, cdr, cadr, caddr, last, append, length, and factorial, all built
;; on Small-Lisp's primitives.
;; Redefined some structures by using PLT's hashtables, instead
;; of using a-lists; therefore, these codes here are heavily
;; dependent on PLT Scheme.
;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.

(module small-lisp-ver.1.3 scheme

  (provide (all-defined-out))

  ;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
  (define (s-assoc x y)
    (hash-ref y x (lambda ()
		    (error-message x)
		    '())))

  (define (error-message x)
    (for-each display
	      `(" **** Unknown expression : " ,x "\n")))

  ;; eval 方面

  (define (atom? x)
    (not (pair? x)))

  (define (s-eval exp env)
    (if (atom? exp)
	(s-number? exp env)
	(let ((key (car exp)) (body (cdr exp)))
	  (case key
	    ((if) (eval-if body env))
	    ((=) (eval-= body env))
	    ((def) (eval-def body env))
	    ((quote) (car body))
	    (else (s-apply key
			   (eval-args body env) env))))))

  ;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
  (define (eval-args exp env)
    (map (lambda (x)
	   (s-eval x env)) exp))

  (define-syntax s-assoc-helper
    (syntax-rules ()
      ((_ exp env pred? proc)
       (let ((it (pred? exp)))
	 (if it
	     (s-assoc (not it) env)
	     (proc exp))))))

  (define (s-number? exp env)
    (if (number? exp)
	exp
	(s-assoc exp env)))

  ;; (define ht (make-hasheq))
  ;; (hash-set! ht #t 'T)
  ;; (hash-set! ht #f '())
  ;; (hash-set! ht 'x '(1 2 3))
  ;; (eval-if '((atom x) x (1st x)) ht) ==> 1
  ;;
  (define (eval-if con env)
    (s-assoc-helper con env null?
		    (lambda (x)
		      (let ((head (car x)) (tail (cdr x)))
			(let ((eval-head (s-eval head env)))
			  (cond ((null? tail) eval-head)
				((not (eq? '() eval-head)) (s-eval (car tail) env))
				(else (eval-if (cdr tail) env))))))))

  (define (eval-= exp env)
    (let ((head (car exp)) (val (s-eval (cadr exp) env)))
      (if (atom? head)
	  (begin (hash-set! env head val) val)
	  (let ((key (cadr head)))
	    (let ((var (s-assoc key env)))
	      (case (car head)
		((car) (hash-set! env key
				  (cons val (cdr var)))
		 (s-assoc key env))
		((cdr) (hash-set! env key
				  (cons (car var)
					(if (pair? val)
					    val
					    `(,val))))
		 (s-assoc key env))
		(else (error-message exp))))))))

  (define (eval-def exp env)
    (let ((name (car exp))
	  (args (cadr exp))
	  (body (third exp)))
      (hash-set! env name `(fn ,args ,body))
      name))

  ;; apply 方面

  (define (s-null? foo env)
    (s-eval (null? foo) env))

  ;; (s-atom? 4) ==> t
  (define (s-atom? foo env)
    (s-eval (not (pair? foo)) env))

  ;; (s-is? 1 1) ==> t
  (define (s-is? foo bar env)
    (s-eval (eq? foo bar) env))

  (define-syntax operator-generator
    (syntax-rules ()
      ((_ name foo bar acc pred? proc)
       (cond ((pred? foo)
	      acc)
	     ((pred? bar)
	      foo)
	     (else
	      (name (proc foo (car bar)) (cdr bar)))))))

  (define (s-+ foo bar)
    (operator-generator s-+ foo bar 0 null? +))

  (define (s-- foo bar)
    (operator-generator s-- foo bar 0 null? -))

  (define (s-* foo bar)
    (operator-generator s-* foo bar 1 null? *))

  (define (s-/ foo bar)
    (operator-generator s-/ foo bar 1 null? /))

  (define-syntax compare-helper
    (syntax-rules ()
      ((_ name foo bar env pred? proc)
       (cond ((pred? foo)
	      (error-message foo))
	     ((pred? bar)
	      (s-assoc #t env))
	     (else
	      (let ((head (car bar)))
		(if (not (proc foo head))
		    (s-assoc (proc foo head) env)
		    (name head (cdr bar) env))))))))

  (define (s-> foo bar env)
    (compare-helper s-> foo bar env null? >))

  (define (s-< foo bar env)
    (compare-helper s-< foo bar env null? <)) 

  (define (s-apply func args env)
    (cond
     ((null? func)
      (error-message args))
     ((pair? func)
      (s-fn? func args env))
     (else
      (let ((head (s-assoc-helper args env null? car))
	    (tail (s-assoc-helper args env null? cdr)))
	(let ((head-of-tail (s-assoc-helper tail env null? car)))
	  ;; 基本関数の処理
	  (case func
	    ((null?) (s-null? head env))
	    ((1st) (s-assoc-helper head env null? car))
	    ((2nd) (s-assoc-helper head env (lambda (x) (< (length x) 2)) cadr))
	    ((3rd) (s-assoc-helper head env (lambda (x) (< (length x) 3)) caddr))
	    ((rst) (s-assoc-helper head env null? cdr))
	    ((cons) (cons head head-of-tail))
	    ((atom?) (s-atom? head env))
	    ((is?) (s-is? head head-of-tail env))
	    ((+) (s-+ head tail))
	    ((-) (s-- head tail))
	    ((*) (s-* head tail))
	    ((/) (s-/ head tail))
	    ((>) (s-> head tail env))
	    ((<) (s-< head tail env))
	    ;; 基本関数以外の関数に対する評価
	    (else (s-apply (s-eval func env) args env))))))))

  ;; lambda式の処理
  (define (s-fn? func args env)
    (if (eq? (car func) 'fn)
	(s-eval (third func)
		(pairlis->hash (cadr func) args env))
	(error-message args)))

  ;; REPL

  ;; プロンプトの表示とS式の読み込み
  (define (prompt)
    (begin (display "SL-USER> ")
	   (read)))

  (define *version* "Small-Lisp Ver.1.3\n")

  (define (slisp)
    (define (loop exp)
      (if (and (list? exp)		;終了条件のチェック
	       (memv (car exp)
		     '(bye quit end exit)))
	  'GOOD-BYE
	  (let ((c (begin (display (null-environment? exp *environment*))
			  (newline))))
	    (loop (prompt)))))
    (display *version*)
    (init-environment)			;環境の初期設定
    (loop (prompt)))			;プロンプトの表示/S式の読み込み

  (define *environment* (make-hasheq))	;大域変数の宣言
  (define (init-environment)		;環境の初期設定
    (hash-set! *environment* #t 't)
    (hash-set! *environment* #f '()))

  ;; (define ht (make-hasheq))
  ;; (hash-set! ht 'foo 3)
  ;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
  ;; (define ht2 (make-hasheq))
  ;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
  ;;
  (define (pairlis->hash x y z)
    (cond ((or (null? x) (null? y)) z)
	  (else (hash-set! z (car x) (car y))
		(pairlis->hash (cdr x) (cdr y) z))))

  (define (null-environment? exp env)
    (let ((it (s-eval exp env)))
      (if (null? it)
	  'NIL
	  (capital-symbol it))))

  (define (capital-symbol exp)
    (cond ((symbol? exp)
	   (string->symbol (string-upcase (symbol->string exp))))
	  ((list? exp)
	   (map capital-symbol exp))
	  (else
	   exp)))
  
  ;; 外部ライブラリのロード用手続き
  (define (slisp-load filename)
    (letrec ((s-load
	      (lambda (p)
		(let ((x (read p)))
		  (cond ((eof-object? x)
			 (close-input-port p))
			(else
			 (s-eval x *environment*)
			 (s-load p)))))))
      (call-with-input-file filename s-load)))

  )