latest version

latest-ver.lisp

;; Examples
;;------------------------------------------------------------------------------
;; 1. non-commands
;;   There are two types of 'non-commands',
;;     a) integers
;;     b) symbols
;;
;;   Symbols are looked up, so if you provide an initial environment, with a 
;;   symbol defined, it will be appropriately looked up.
;;     e.g: (lookup 'x '((x . 0))) -> 0
;;   Lambdas are not necessary, but it would be trivial to add them by providing a
;;   lambda form in the evaluator.
;;
;;  (eval1 1 nil)         -> 1
;;  (eval1 'x '((x . 0))) -> 0

;; 2. commands

;; (i m n)        -> (setf image (make-image n m))
;; (c)            -> (clear image)
;; (l x y c)      -> (colour-pixel image x y c)
;; (v x y1 y2 c)  -> (draw-vertical-segment image x y1 y2 c)
;; (h x1 x2 y c)  -> (draw-horizontal-segment image x1 x2 y c)
;; (f x y c)      -> (fill-region image x y c)
;; (s)            -> (show image)
;; (x)            -> (terminate)
;;
;; e.g: (eval1 '(i (i 0 1) 1) nil)
;; compiles to: (SETF IMAGE (MAKE-IMAGE (SETF IMAGE (MAKE-IMAGE 0 1)) 1))
;; where: image is a dynamically bound variable
;;
;; (eval1 '(l 1 2 3) nil)
;;
;; Since the compiled forms compile to common-lisp primitives, our evaluator
;; is not powerful enough to run them. However, common-lisp can compile these
;; in turn to native code. :)
;;
;; Program Sample:
;; 
;; (i 10 10)         ;; create a 10x10 image
;; (f 0 0 'black)    ;; fill the region with white
;; (c)               ;; clear the image
;; (l 5 5 'red)      ;; colour a pixel
;; (v 0 5 10 'blue)  ;; draw a blue vertical segment
;; (h 5 10 0 'green) ;; draw a green horizontal segment
;; (s)               ;; show the image
;; (x)               ;; exit
;;
;; Compiler Backends:
;;    
;;   The evaluator can compile commands to either:
;;     a) Common Lisp
;;     b) Ruby
;;
;;   Example:
;;
;;     (eval->cl '(begin (i 10 10) (f 0 0 'black) (c)))
;;       -> (progn
;;            (setf image (make-image 10 10))
;;            (fill-region image 0 0 'black)
;;            (clear image))
;;
;;     (eval-ruby '(begin (i 10 10) (f 0 0 'black) (c)))
;;       -> image = make_image(10, 10)
;;          fill_region(image, 0, 0, :black)
;;          clear(image)

(ql:quickload :cl-ppcre)

(defun repl ()
  (let* ((line    (read-line1))
	 (command (eval1 line nil)))
    (unless (and (symbolp command)
		 (eq command 'exit))
      (format t "output: ~a~%" command)
      (repl))))

(defun read-line1 ()
  (let ((line (cl-ppcre:split " " (read-line))))
    (cond ((string= "I" (elt line 0))
	   (list 'i
		 (parse-integer (elt line 1))
		 (parse-integer (elt line 2))))
	  ((string= "C" (elt line 0))
	   (list 'c))
	  ((string= "L" (elt line 0))
	   (list 'l
		 (parse-integer (elt line 1))
		 (parse-integer (elt line 2))
		 (coerce (elt line 3) 'character)))
	  ((string= "V" (elt line 0))
	   (list 'v
		 (parse-integer (elt line 1))
		 (parse-integer (elt line 2))
		 (parse-integer (elt line 3))
		 (coerce (elt line 4) 'character)))
	  ((string= "H" (elt line 0))
	   (list 'h
		 (parse-integer (elt line 1))
		 (parse-integer (elt line 2))
		 (parse-integer (elt line 3))
		 (coerce (elt line 4) 'character)))
	  ((string= "F" (elt line 0))
	   (list 'f
		 (parse-integer (elt line 1))
		 (parse-integer (elt line 2))
		 (coerce (elt line 4) 'character)))
	  ((string= "S" (elt line 0))
	   (list 's))
	  ((string= "X" (elt line 0))
	   (list 'x))
	  (t
	   (error "Unrecognized command")))))

(defun compile-ruby (exp)
  (format t "~a~%" exp)
  (cond ((integerp exp)
	 (format nil "~a" exp))
	((characterp exp)
	 (format nil "'~a'" exp))
	((eq (car exp) 'i)
	 (format nil "make_image(~{~a,~})~%" (cdr exp)))
	((eq (car exp) 'c)
	 (format nil "clear(image)~%"))
	((eq (car exp) 'l)
	 (format nil "colour_pixel(image, ~{~a,~})~%" (cdr exp)))
	((eq (car exp) 'v)
	 (format nil "draw_vertical_segment(image, ~{~a~})~%" (cdr exp)))
	((eq (car exp) 'h)
	 (format nil "draw_horizontal_segment(image, ~{~a~})~%" (cdr exp)))
	((eq (car exp) 'f)
	 (format nil "fill_region(image, ~{~a~})~%" (cdr exp)))
	((eq (car exp) 's)
	 (format nil "show(image)~%"))
	((eq (car exp) 'x)
	 'exit)
	(t (error "Unrecognized expression."))))

(defun compile-cl (exp)
  "Compiles a primitive command to common-lisp."
  (cond ((or (integerp exp)
	     (characterp exp))
	 exp)
	((eq (car exp) 'i) 
	 `(setf image (make-image ,@(cdr exp))))
	((eq (car exp) 'c)
	 `(clear image))
	((eq (car exp) 'l)
	 `(colour-pixel image ,@(cdr exp)))
	((eq (car exp) 'v)
	 `(draw-vertical-segment image ,@(cdr exp)))
	((eq (car exp) 'h)
	 `(draw-horizontal-segment image ,@(cdr exp)))
	((eq (car exp) 'f)
	 `(fill-region image ,@(cdr exp)))
	((eq (car exp) 's)
	 `(show image ,@(cdr exp)))
	((eq (car exp) 'x)
	 'exit)
	(t
	 (error "Unrecognised expression..."))))

(let* ((compiler-backend #'compile-cl)
       (applicator (make-applicator)))

  (defun get-compiler-backend () 
    compiler-backend)
  (defun set-compiler-backend! (b) 
    (setf compiler-backend b
	  applicator (make-applicator)))

  (defun eval-sequence (exps env)
    "Evaluates a sequence of expressions."
    (loop for exp in exps 
	  collect (eval1 exp env)))

  (defun lookup (symbol env)
    "Looks up a symbol in an environment."
    (loop for s in env do
      (when (eq symbol (car s))
	(return (cdr s)))
	  :finally (error "Symbol undefined")))

  (defun extend-environment (env args params)
    "Extends an environment with a set of parameters."
    (append env
	    (loop for arg in args
		  for param in params
		  collect (cons arg param))))

  (defun eval1 (exp env)
    "Evaluates an expression within an environment."
    (cond ((or (integerp exp)
	       (characterp exp))
	   exp)
	  ((symbolp exp)
	   (lookup exp env))
	  (t 
	   (funcall applicator
		    (car exp)
		    (eval-sequence (cdr exp) env)
		    env))))

  (defun make-evaluator ()
    (lambda (exp env)
      (eval1 exp env)))

  (defun primitive-command? (fn-name)
    "Is this expression a primitive command?"
    (loop for primitive in '(i c l v h s f x) do
      (when (eq primitive fn-name)
	(return t))
	  finally (return nil)))

  (defun apply1 (fn-name params env)
    "Apply a function to a set of parameters within an environment."
    (if (primitive-command? fn-name)
	(funcall compiler-backend (cons fn-name params))
	(let ((proc (lookup fn-name env)))
	  (cond ((> (length (car proc)) params)
		 (error "Not enough parameters supplied to function"))
		((< (length (car proc)) params)
		 (error "Too many parameters supplied to function"))
		(t
		 (eval1 (cdr proc) (extend-environment env (car proc) params)))))))

  (defun make-applicator ()
    (lambda (fn-name params env)
      (apply1 fn-name params env))))

(set-compiler-backend! #'compile-ruby)
(eval1 '(i 10 10) nil)
(eval1 '(c) nil)
(eval1 '(l 1 1 1) nil)
;;(eval1 '(v 0 1 0 :white) nil)
;;(eval1 '(h 1 0 0 :white) nil)