; Author: Paul Fitzpatrick, paulfitz@ai.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 (define fritz-eval-proc (lambda (func arg env) (begin (if (equal? (length arg) 0) func (fritz-eval-proc (func (fritz-eval-term (car arg) env) env) (cdr arg) env))))) (define fritz-eval-exp (lambda (exp env) (let ((cmd (car exp)) (arg (cdr exp))) (begin (cond ((or (equal? cmd 0) (equal? cmd '?)) (begin (let ((idx (car arg)) (bdy (fritz-second arg))) (begin (lambda (x dynamic-env) (fritz-eval-term bdy (lambda (y) (if (equal? y idx) x (env y))))))))) ((or (equal? cmd 18) (equal? cmd 'if)) (begin (let ((cnd (car arg)) (exp1 (car (cdr arg))) (exp2 (car (cdr (cdr arg))))) (let ((ok (fritz-eval-term cnd env))) (if ok (fritz-eval-term exp1 env) (fritz-eval-term exp2 env)))))) (else (let ((ecmd (fritz-eval-term cmd env))) (if (not (procedure? ecmd)) (fritz-eval-proc (env ecmd) arg env) (fritz-eval-proc ecmd arg env))))))))) (define fritz-second (lambda (lst) (if (list? (cdr lst)) (car (cdr lst)) lst))) (define fritz-eval-term (lambda (exp env) (begin (cond ((not (list? exp)) exp) (else (fritz-eval-exp exp env)))))) (define fritz-unary (lambda (n) (lambda (x exp) (if (equal? x 0) n (fritz-unary (+ n 1)))))) (define fritz-eval-sexp (lambda (exp) (fritz-eval-term exp (lambda (x) ((cell-contents fritz-initial-environment) x))))) (define fritz-eval-show (lambda (exp) (let ((result (fritz-eval-sexp exp))) (begin (if (equal? #t result) (display "ok: ") (display "BAD: ")) (display exp) (display "\n"))))) (define fritz-compile-paren (lambda (exp) (if (list? exp) (cons '< (append (append-map fritz-compile-paren exp) (list '>))) (list (list 'constant exp))))) (define fritz-initial-environment (make-cell (lambda (x) (cond ((or (equal? x 1) (equal? x '+)) (lambda (x env) (lambda (y env) (+ x y)))) ((or (equal? x 2) (equal? x '*)) (lambda (x env) (lambda (y env) (* x y)))) ((or (equal? x 3) (equal? x '-)) (lambda (x env) (lambda (y env) (- x y)))) ((or (equal? x 4) (equal? x '/)) (lambda (x env) (lambda (y env) (quotient x y)))) ((or (equal? x 5) (equal? x '=)) (lambda (x env) (lambda (y env) (equal? x y)))) ((or (equal? x 6) (equal? x 'not)) (lambda (x env) (not x))) ((or (equal? x 7) (equal? x 'intro)) (lambda (x env) #t)) ((equal? x 8) (fritz-unary 0)) ((or (equal? x 9) (equal? x '<=)) (lambda (x env) (lambda (y env) (<= x y)))) ((or (equal? x 10) (equal? x '>=)) (lambda (x env) (lambda (y env) (>= x y)))) ((or (equal? x 11) (equal? x '<)) (lambda (x env) (lambda (y env) (< x y)))) ((or (equal? x 12) (equal? x '>)) (lambda (x env) (lambda (y env) (> x y)))) ((or (equal? x 13) (equal? x 'and)) (lambda (x env) (lambda (y env) (and x y)))) ((or (equal? x 14) (equal? x 'or)) (lambda (x env) (lambda (y env) (or x y)))) ((or (equal? x 15) (equal? x 'false)) #f) ((or (equal? x 16) (equal? x 'true)) #t) ((or (equal? x 17) (equal? x 'define)) (lambda (x env) (lambda (y env) (let ((old-env (cell-contents fritz-initial-environment))) (begin (set-cell-contents! fritz-initial-environment (lambda (z) (if (equal? z x) y (old-env z)))) #t))))) ((or (equal? x 18) (equal? x 'if)) (lambda (x env) (lambda (y env) (lambda (z env) (if x y z))))) ((or (equal? x 19) (equal? x 'forall)) (lambda (x env) (and (x 10 env) (x -20 env) (x 888 env)))) ;; try a few samples - not real code ((or (equal? x 20) (equal? x 'exists)) (lambda (x env) (let loop ((n -10)) ;; try a few samples - not real code (if (x n env) #t (if (< n 20) (loop (+ n 1)) #f))))) (else (list 'unknown-identifier x)))))) (define fritz-compile-flat (lambda (exp env count) (if (> (length exp) 0) (let ((key (car exp)) (rest (cdr exp))) (if (list? key) (if (number? (second key)) (append (list (second key)) (fritz-compile-flat rest env count)) (if (>= (env (second key)) 0) (append (list (env (second key))) (fritz-compile-flat rest env count)) (append (list count) (fritz-compile-flat rest (lambda (x) (if (equal? x (second key)) count (env x))) (+ count 1))))) (cons key (fritz-compile-flat rest env count)))) (list)))) (define fritz-compile-sexp (lambda (exp) (let ((flat (fritz-compile-paren exp))) (fritz-compile-flat flat (lambda (x) ((cell-contents fritz-initial-environment) x)) 100)))) (define fritz-binary (lambda (n) (cond ((> n 1) (append (fritz-binary (quotient n 2)) (list (modulo n 2)))) ((equal? n 1) (list 1)) (else (list 0))))) (define fritz-tokenize (lambda (exp) (append-map (lambda (term) (if (number? term) (append (list '<) (fritz-binary term) (list '>)) (list term))) exp))) (define fritz-binarize (lambda (exp) (append-map (lambda (key) (cond ((equal? key '>) (list 0 0 1 1)) ((equal? key '<) (list 0 0 1 0)) ((equal? key '0) (list 0 0 0 0)) ((equal? key '1) (list 0 0 0 1)) ((equal? key 'x) (list 0 1 1 1)) (else (error "unknown token " key (list? 'x))))) exp))) (define fritz-debinarize (lambda (exp) (if (>= (length exp) 3) (let ((bit1 (car exp)) (bit2 (car (cdr exp))) (bit3 (car (car (cdr exp))))) 0)))) (define fritz-detokenize-helper (lambda (exp num lst ret) (if (equal? (length exp) 0) (ret exp lst) (let ((token (car exp)) (rem (cdr exp))) (cond ((equal? token '1) (fritz-detokenize-helper rem (+ (* 2 num) 1) lst ret)) ((equal? token '0) (fritz-detokenize-helper rem (+ (* 2 num) 0) lst ret)) ((equal? token '<) (fritz-detokenize-helper rem 0 '() (lambda (nexp nlst) (fritz-detokenize-helper nexp -1 (append lst nlst) ret)))) ((equal? token '>) (ret rem (if (>= num 0) (list num) (list lst))))))))) (define fritz-detokenize (lambda (exp) (car (fritz-detokenize-helper exp -1 '() (lambda (nexp nlst) nlst))))) ; (define fritz-evaluate ; (lambda (exp) ; (warn "exp " exp) ; (if (list? exp) ; (let ((cmd (car exp)) ; (rem (cdr exp))) ; (warn "OUTER " cmd rem) ; (cond ((equal? cmd 0) ; (let ((formal (car rem)) ; (body (car (cdr rem)))) ; (lambda (x) ; (begin ; (warn "procedure with formal arg " formal " called with " x " and has body " body (list? body)) ; (eval (list 'let ; (list ; (list (intern ; (string-append "frtz-" ; (number->string formal))) ; 'x)) ; ; (list 'fritz-evaluate 'body)) ; (intern ; (string-append "frtz-" ; (number->string formal)))) ; (the-environment)))))) ; ((equal? cmd 17) ; (let ((formal (car rem)) ; (body (car (cdr rem)))) ; (eval (list 'begin ; (list 'define ; (intern ; (string-append "frtz-" ; (number->string formal))) ; (fritz-evaluate body)) ; #t) ; user-initial-environment))) ; (else (let ((func-id (fritz-evaluate cmd))) ; (warn "evaluating procedure call " func-id rem) ; (warn (environment-bindings (the-environment))) ; (warn (environment-bindings (environment-parent (the-environment)))) ; (warn (environment-bindings (environment-parent (environment-parent (the-environment))))) ; (warn (environment-bindings (environment-parent (environment-parent (environment-parent (the-environment)))))) ; (warn (environment-bindings (environment-parent (environment-parent (environment-parent (environment-parent (the-environment))))))) ; (let ((func (if (number? func-id) ; (eval (intern ; (string-append "frtz-" ; (number->string func-id))) ; (the-environment)) ; func-id))) ; (if (> (length rem) 0) ; (if (> (length rem) 1) ; (fritz-evaluate ; (cons ; (func (fritz-evaluate (car rem))) ; (cdr rem))) ; (func (fritz-evaluate (car rem)))) ; func)))))) ; exp))) (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 fritz-unary-bare (lambda (n) (lambda (x) (if (equal? x 0) n (fritz-unary-bare (+ n 1)))))) (define fritz-1 (lambda (x) (lambda (y) (+ x y)))) (define fritz-2 (lambda (x) (lambda (y) (* x y)))) (define fritz-3 (lambda (x) (lambda (y) (- x y)))) (define fritz-4 (lambda (x) (lambda (y) (quotient x y)))) (define fritz-5 (lambda (x) (lambda (y) (if (and (procedure? x) (procedure? y)) ((fritz-5 (x 102)) (y 102)) (begin ; (if (and (number? x) (>= x 200)) ; (begin ; (display "spot") ; (display x) ; (display " ") ; (display y) ; (display "\n")) ; #t) (equal? x y)))))) (define fritz-6 (lambda (x) (not x))) (define fritz-7 (lambda (x) #t)) (define fritz-8 (fritz-unary-bare 0)) (define fritz-9 (lambda (x) (lambda (y) (<= x y)))) (define fritz-10 (lambda (x) (lambda (y) (>= x y)))) (define fritz-11 (lambda (x) (lambda (y) (< x y)))) (define fritz-12 (lambda (x) (lambda (y) (> x y)))) (define fritz-13 (lambda (x) (lambda (y) (and x y)))) (define fritz-14 (lambda (x) (lambda (y) (or x y)))) (define fritz-15 #f) (define fritz-16 #t) (define fritz-17 #f) (define fritz-18 #f) (define fritz-19 (lambda (x) (and (x -5) (x 10) (x 15) (x 18)))) ;; try a few samples - not real code (define fritz-20 (lambda (x) (let loop ((n -10)) ;; try a few samples - not real code (if (x n) #t (if (< n 20) (loop (+ n 1)) #f))))) (define fritz-21 (lambda (x) (lambda (y) (cons x y)))) (define fritz-22 (lambda (x) (car x))) (define fritz-23 (lambda (x) (cdr x))) (define fritz-24 (lambda (x) (number? x))) ;;; fritz-25 is translator ;;; fritz-26 is lambda (define fritz-27 (lambda (x) (make-cell x))) (define fritz-28 (lambda (x) (lambda (y) (begin (set-cell-contents! x y) #t)))) (define fritz-29 (lambda (x) (cell-contents x))) (define fritz-30 (lambda (x) (fritzify-list (let loop ((n -50)) ;; try a few samples - not real code (let ((rest (if (< n 50) (loop (+ n 1)) '()))) (if (x n) (append (list n) rest) rest)))))) ;;(fritz-30 (lambda (x) #t)) ;;(fritz-30 (lambda (x) (equal? (+ x 10) 15))) (define fritz-31 (fritz-30 (lambda (x) (>= x 0)))) (define fritz-32 #f) ;; (set x 10 foo) ;;(define fritz-33 ;; (lambda (x) ;; (lambda (v) ;; (lambda (cmd) ;; cmd)))) (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))) '()))))))) ;(fritzify-list '(1 2 (5) 20)) ;(defritzify-list (fritzify-list '(1 2 (3 5) 20))) ; expects an input that is compatible with FRITZ lists ; (cons list-length list-content) ; (lambda (x) (fritz-translate (defritzify-list x)))) (define fritz-translate (lambda (exp0) (let ((exp (fritzify-list exp0))) (fritz-25 exp)))) (define fritz-25 (lambda (exp0) (let ((exp (defritzify-list exp0))) (if (not (number? exp)) (let ((cmd (car exp)) (rem (cdr exp))) (cond ((equal? cmd 0) (let ((formal (car rem)) (body (car (cdr rem)))) (list 'lambda (list (intern (string-append "fritz-" (number->string formal)))) (fritz-translate body)))) ((equal? cmd 17) (let ((formal (car rem)) (body (car (cdr rem)))) (list 'begin (list 'define (intern (string-append "fritz-" (number->string formal))) (fritz-translate body)) #t))) ((equal? cmd 33) (let ((formal (car rem)) (value (car (cdr rem))) (body (car (cdr (cdr rem))))) (list (list 'lambda (list (intern (string-append "fritz-" (number->string formal)))) (fritz-translate body)) (fritz-translate value)))) ((equal? cmd 18) (let ((cnd (car rem)) (on1 (car (cdr rem))) (on0 (car (cdr (cdr rem))))) (list 'if (fritz-translate cnd) (fritz-translate on1) (fritz-translate on0)))) (else (let ((func-id (fritz-translate cmd))) (let ((func (if (number? func-id) (intern (string-append "fritz-" (number->string 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-translate (car arg)))) (list base (fritz-translate (car arg))))) func)))))) exp)))) (define fritz-translate-show (lambda (exp) (let ((result (fritz-25 (fritzify-list exp)))) (begin (display " Convert: ") (display exp) (display "\n") (let ((val (eval result user-initial-environment))) ;(display " Scheme: ") ;(display result)) ;(display "\n") (if (equal? val #t) (display "ok") (begin (display "UNEXPECTED RESULT ") (display val))) (display "\n")))))) (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))))) '()))) ;(fritz-break-list '(1 (1 2 3 -1 4 5) 2 3 -1 4 5 -1 8 9)) ;(fritz-translate-show '10) ;(defritzify-list '10) ;(17 155 (0 100 (0 156 (18 (5 (139 (100)) 0) (25 (156)) (155 (138 (100)) (153 (153 0 (135 (135 (100))) (156)) (138 (135 (100))))))))) ;(fritz-translate-show '(155 ((x 10)) 5)) ;(fritz-translate-show '(7 (8 1 1 1 1 1 1 1 1 1 1 0))) ;(fritz-translate-show '(7 -1 8 1 1 1 1 1 1 1 1 1 1 0))