;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; *************************** define reader macros ***************************
(eval-when (:load-toplevel :execute)
  (defmacro char-macro (ch &body body)
    `(set-macro-character ,ch #'(lambda (stream char)
				  (declare (ignore char)) ,@body)))

  ; define syntax of N-expression
  (char-macro #\[
    (reduce #'(lambda (&rest exp)
		(if (functionp (car exp)) exp `(list ,@exp)))
	    (read-delimited-list #\] stream t)
	    :from-end t))

  (set-syntax-from-char #\] #\))

  (defun div (a b) (/ a b))  ; we will want to preserve
  (defun mul (a b) (* a b))  ; and use '/', '*', and '='
  (defun es (a b) (= a b))   ; after they are clobbered.

  (defvar %nk-ops% '()) ; table of Nock operator names

  (macrolet ((opchar (ch name) ; mutilate the Lisp reader into a Nock reader
	       `(progn
		  (push (cons ',name ,ch) %nk-ops%)
		  (char-macro ,(character ch)
		    (list ',name (read stream t nil t))))))
    (opchar "?" QMARK)  (opchar "^" CARROT) (opchar "=" EQSIG)
    (opchar "/" FSLASH) (opchar "*" NOCK))
)
; *************************** define reader macros ***************************

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun nkcar (E) (if (listp E) (car E) E))
  (defun nkcdr (E) (if (listp E) (cadr E) nil))
  (defun cellp (exp) (and (listp exp) (not (symbolp (car exp)))))

  (defun nk-print (E)
    (cond ((null E) "")
	  ((atom E) (write-to-string E))
	  ((listp E)
	   (let ((hd (car E)))
	     (if (symbolp hd)
		 (concatenate 'string
			      (cdr (assoc hd %nk-ops%)) (nk-print (cadr E)))
		 (concatenate 'string
			      "[" (nk-print hd) " " (nk-print (cadr E)) "]"))))))

  (defmacro mk-op (name &body body)
    `(defun ,name (args)
       (let ((hd (nkcar args))
	     (tl (nkcdr args))
	     (same (list ',name args)))
	 ,@body)))

  (mk-op QMARK (declare (ignore hd same)) (if (null tl) 1 0))
  (mk-op CARROT (if (and (null tl) (numberp hd)) (1+ hd) same))
  (mk-op EQSIG (if (and (atom hd) (atom tl)) (if (eq hd tl) 0 1) same))

  (mk-op FSLASH
    (if (null tl)
	same
	(cond
	  ((eq hd 1) tl)
	  ((and (eq hd 2) (cellp tl)) (car tl))
	  ((and (eq hd 3) (cellp tl)) (cadr tl))
	  ((and (numberp hd) (> hd 3))
	   (if (evenp hd)
	       /[2 /[(div hd 2) tl]]
	       /[3 /[(div (1- hd) 2) tl]]))
	  (t same))))

  (mk-op NOCK
    (if (cellp tl)
	(let ((x (car tl))
	      (b (cadr tl)))
	  (if (cellp x)
	      [*[hd x] *[hd b]]
	      (case x
		(0 /[b hd])
		(1 b)
		(2 (if (cellp (nkcdr b))
		       *[hd 3 [0 1] 3 [1 (caadr b) (cadadr b)]
		        [1 0] 3 [1 2 3] [1 0] 5 5 (car b)]
		       same))
		(3 **[hd b])
		(4 ?*[hd b])
		(5 ^*[hd b])
		(6 =*[hd b])
		(t same))))
	same))

  (defun nockl ()
    (loop
       (format t "~&NOCK> ")
       (finish-output nil)
       (let ((form (read)))
	 (if (eq form :q) (quit))
	 (write-string (nk-print (eval form)))
	 )))

  (defun nock-repl ()
    (format t "~&Type any Nock expression, or :q to exit.~%~%")
    (nockl))

  (nock-repl) ; enter the REPL.
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;