;   Author: Paul Fitzpatrick, paulfitz@csail.mit.edu
;   Copyright (c) 2003 Paul Fitzpatrick
;
;   This file is part of CosmicOS.
;
;   CosmicOS 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.
;
;   CosmicOS 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.
;
;   You should have received a copy of the GNU General Public License
;   along with CosmicOS; if not, write to the Free Software
;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Load some resources

;; Load look-up table for names of built-in procedures
(load "identifiers")

;; Load entire message as a list-of-lists, to allow programmatic access
(load "primer")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper procedures to deal with differences between CosmicOS lists
;; and Scheme lists.
;; In CosmicOS, lists contain their length as the first element of
;; a CONS structure.

(define fritz-break-list
  (lambda (in)
    (if (> (length in) 0)
	(let ((top (car in))
	      (rem (cdr in)))
	  (if (list? top)
	      (cons (fritz-break-list top) (fritz-break-list rem))
	      (if (= top -1)
		  (list (fritz-break-list rem))
		  (cons top (fritz-break-list rem)))))
	'())))

(define fritzify-list
  (lambda (exp)
    (if (number? exp)
	exp
	(cons (length exp)
	      (if (> (length exp) 1)
		  (cons (fritzify-list (car exp)) 
			(cdr (fritzify-list (cdr exp))))
		  (if (> (length exp) 0)
		      (fritzify-list (car exp))
		      0))))))

(define defritzify-list
  (lambda (exp)
    (if (number? exp)
	exp
	(fritz-break-list
	 (let ((n (car exp)))
	   (if (> n 1)
	       (append (list (defritzify-list (car (cdr exp))) )
		       (defritzify-list (cons (- n 1) (cdr (cdr exp)))))
	       (if (> n 0)
		   (list (defritzify-list (cdr exp)))
		   '())))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper procedures to deal with differences between CosmicOS true/false
;; values and Scheme true/false values.
;; In CosmicOS, true equals integer 1, and false equals integer 0.

;; tish: "truth-ish" -- convert a number to a truth-value
(define tish
  (lambda (x)
    (> x 0)))

;; nish: "number-ish" -- convert a truth-value to a number
(define nish
  (lambda (x)
    (if x 1 0)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Built-in procedures

(define cos-intro
  (lambda (x) (nish #t)))

(define cos-=
  (lambda (x) (lambda (y) 
		(nish
		 (equal? x y)))))

(define cos->
  (lambda (x) (lambda (y) (nish (> x y)))))

(define cos-<
  (lambda (x) (lambda (y) (nish (< x y)))))

(define cos-+
  (lambda (x) (lambda (y) (+ x y))))

(define cos-*
  (lambda (x) (lambda (y) (* x y))))

(define cos--
  (lambda (x) (lambda (y) (- x y))))

(define cos-not
  (lambda (x) (nish (not (tish x)))))

(define cos-<=
  (lambda (x) (lambda (y) (nish (<= x y)))))

(define cos->=
  (lambda (x) (lambda (y) (nish (>= x y)))))

(define cos-and
  (lambda (x) (lambda (y) (nish (and (tish x) (tish y))))))

(define cos-or
  (lambda (x) (lambda (y) (nish (or (tish x) (tish y))))))

(define cos-false
  (nish #f))

(define cos-true
  (nish #t))

(define cos-cons
  (lambda (x) (lambda (y) (cons x y))))

(define cos-car
  (lambda (x) (car x)))

(define cos-cdr
  (lambda (x) (cdr x)))

(define cos-number?
  (lambda (x) (nish (number? x))))

(define cos-translate
  (lambda (exp0)
    (let ((exp (defritzify-list exp0)))
      (fritz-translate exp))))

(define cos-make-cell
  (lambda (x)
    (make-cell x)))

(define cos-set!
  (lambda (x)
    (lambda (y)
      (begin (set-cell-contents! x y)
	     (nish #t)))))

(define cos-get!
  (lambda (x)
    (cell-contents x)))

(define cos-div
  (lambda (x) (lambda (y) (quotient x y))))

(define cos-primer
  (fritzify-list (fritz-break-list fritz-primer)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Minor built-in procedures that could be stripped without affecting
;; important parts of the message

(define cos-forall
  (lambda (x)
    (nish (and (tish (x -5)) (tish (x 10)) (tish (x 15)) (tish (x 18)))))) ;; try a few samples - not real code

(define cos-exists
  (lambda (x)
    (nish
     (let loop ((n -10))   ;; try a few samples - not real code
       (if (tish (x n))
	   #t
	   (if (< n 20)
	       (loop (+ n 1))
	       #f))))))

(define cos-all
  (lambda (x)
    (fritzify-list
     (let loop ((n -50))   ;; try a few samples - not real code
       (let ((rest (if (< n 50)
		       (loop (+ n 1))
		       '())))
	 (if (tish (x n))
	     (append (list n) rest)
	     rest))))))

(define cos-natural-set
  (cos-all (lambda (x) (nish (>= x 0)))))

(define cos-undefined
  #f)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Place-holders: value should never be checked in practice, and
;; are just assigned here to catch potential bugs

;;; "lambda" gets created in message, value here doesn't matter
(define cos-lambda
  (nish #f))

;; "define" gets intercepted, value here doesn't matter
(define cos-define
  (nish #f))

;; "if" gets intercepted, value here doesn't matter
(define cos-if
  (nish #f))

;; "assign" gets intercepted, value here doesn't matter
(define cos-assign
  (nish #f))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Evaluation

;; this is the core "translate" procedure.
;; It converts the FRITZ expression it receives into SCHEME code.
;; (expects a SCHEME-style list rather than a FRITZ-style list)
(define fritz-translate
  (lambda (exp)
    (if (not (number? exp))
	(let ((cmd (car exp))
	      (rem (cdr exp)))
	  (cond ((equal? cmd 0)
		 ;; expression evaluates to a procedure
		 (let ((formal (car rem))
		       (body (car (cdr rem))))
		   (list 'lambda
			 (list (intern 
				(string-append "cos-" 
					       (fritz-name formal))))
			 (fritz-sub-translate body))))
		;; expression defines a procedure
		((equal? cmd 17)
		 (let ((formal (car rem))
		       (body (car (cdr rem))))
		   (list 'begin
			 (list 'define 
			       (intern 
				  (string-append "cos-" 
						 (fritz-name formal)))
			       (fritz-sub-translate body))
			 (nish #t))))
		;; assignment shorthand
		((equal? cmd 11)
		 (let ((formal (car rem))
		       (value (car (cdr rem)))
		       (body  (car (cdr (cdr rem)))))
		   (list
		    (list 'lambda
			  (list (intern 
				 (string-append "cos-" 
						(fritz-name formal))))
			  (fritz-sub-translate body))
		    (fritz-sub-translate value))))
		;; expression is an if statement
		((equal? cmd 18)
		 (let ((cnd (car rem))
		       (on1 (car (cdr rem)))
		       (on0 (car (cdr (cdr rem)))))
		   (list 'if
			 (list 'tish (fritz-sub-translate cnd))
			 (fritz-sub-translate on1)
			 (fritz-sub-translate on0))))
		;; expression is a procedure call
		(else (let ((func-id (fritz-sub-translate cmd)))
			(let ((func (if (number? func-id)
					(intern 
					 (string-append "cos-" 
							(fritz-name func-id)))
					func-id)))
			  (if (> (length rem) 0)
			      (let loop ((n (length rem))
					 (arg rem)
					 (base func))
				(if (> n 1)
				    (loop (- n 1) (cdr arg)
					  (list base (fritz-sub-translate (car arg))))
				    (list base (fritz-sub-translate (car arg)))))
			      func))))))
	exp)))

;; Translate via cos-translate; this is necessary so that
;; cos-translate can be overridden within the body of the method.
(define fritz-sub-translate
  (lambda (exp)
    (cos-translate (fritzify-list exp))))


;; Execute a single CosmicOS expression
;; Result is expected to be true (integer 1)
(define fritz-translate-show
  (lambda (exp)
    (begin 
      (display "    Expression: ")
      (display exp)
      (display "\n")
      (let ((result (cos-translate (fritzify-list exp))))
	(begin
	  (display "    Translation: ")
	  (display result)
	  (display "\n")
	  (let ((val (eval result user-initial-environment)))
	    (if (equal? val 1)
		(display "ok")
		(begin
		  (display "UNEXPECTED RESULT ")
		  (display val)))
	    (display "\n")))))))