path: root/ps04_combinators_amb/bnewbold_ps04_work.scm

;;; 6.945 Problem Set #4 Source Code
;;; 03/04/2009
;;; Bryan Newbold <bnewbold@mit.edu>

; Note: this file is usually loaded from the load-*.scm files into 
; the-generic-evaluation-environment

;---------------------------
; Problem 4.1

#| ; This conflicts with the infix code below, so leave it commented in
   ; when testing that code.

(defhandler execute-application
  (lambda (proc args)
    ((procedure-body proc)
     (if (list? (procedure-parameters proc))
	 (extend-environment 
	  (procedure-parameters proc)
	  args
	  (procedure-environment proc))
	 (extend-environment 
	  (list (procedure-parameters proc))
	  (list args)
	  (procedure-environment proc)))))
     compound-procedure?)
|#
#| Testing:

eval> (define (ss . x) (map square x))
ok
eval> (ss 1 2 3)
(1 4 9)

; and the regular syntax still works:

eval> (define (s2 x y) (list (square x) (square y)))
ok
eval> (s2 1 2 3 4 5)
;Too many arguments supplied (x y) (1 2 3 4 5)
eval> (s2 1 2)
(1 4)
|#


;---------------------------
; Problem 4.2

; first we gotta listify the infix string or life will suck
(define (infix-operator? x)
  (member x (string->list "+-*^/")))
(define (infix-open-paren? x)
  (member x (string->list "(")))
(define (infix-close-paren? x)
  (member x (string->list ")")))
(define (infix-var? x)
  (member x (string->list "abcdefghijklmnopqrstuvwxyz")))
(define (infix-number? x)
  (member x (string->list "0123456789")))
(define (infix-same-type? a b)
  (cond ((infix-operator? a) (infix-operator? b))
	((infix-open-paren? a) (infix-open-paren? b))
	((infix-close-paren? a) (infix-close-paren? b))
	((infix-number? a) (infix-number? b))
	((infix-var? a) (infix-var? b))
	(else (error "Not a valid infix char type: " a))))
(define (infix-tag-type x)
  (let ((tag (cond ((infix-operator? (car x)) 'oper)
		   ((infix-open-paren? (car x)) 'open-paren)
		   ((infix-close-paren? (car x)) 'close-paren)
		   ((infix-var? (car x)) 'variable)
		   ((infix-number? (car x)) 'number)
		   (else (error "Something wrong, not a type: " x)))))
    (list tag (list->string (reverse x)))))

(define (listify in)
  (define out '())
  (define prog '())
  (define (work chunk)
    (cond ((null? chunk)
	   (cons (infix-tag-type prog) out))
	  ((equal? (car chunk) #\space)
	   (work (cdr chunk)))
	  ((null? prog) 
	   (begin
	     (set! prog (cons (car chunk) prog))
	     (work (cdr chunk))))
	  ((and (infix-same-type? (car prog) (car chunk))
		(not (or (infix-open-paren? (car prog))
			 (infix-close-paren? (car prog)))))
	   (begin 
	     (set! prog (cons (car chunk) prog))
	     (work (cdr chunk))))
	  (else 
	   (begin
	     (set! out (cons (infix-tag-type prog) out))
	     (set! prog (list (car chunk)))
	     (work (cdr chunk))))))
  (reverse (work (string->list in))))

#| Test:
(listify "4+34^4-(a*a+b^2)")
;Value: ((number "4") (oper "+") (number "34") (oper "^") (number "4") (oper "-") (open-paren "(") (var "a") (oper "*") (var "a") (oper "+") (var "b") (oper "^") (number "2") (close-paren ")"))

(listify "4+34^4 - ( a*a + b^2)")
;Value: ((number "4") (oper "+") (number "34") (oper "^") (number "4") (oper "-") (open-paren "(") (var "a") (oper "*") (var "a") (oper "+") (var "b") (oper "^") (number "2") (close-paren ")"))
|#

; alright, now we can do fun NLP mojo


#| These definitions should be pasted into an amb-evaluator:

(define (require p)
  (if (not p) (amb)))

(define *unparsed* '())

(define (parse-type t)
  (require (not (null? *unparsed*)))
  (require (equal? (caar *unparsed*) t))
  (let ((found-type (car *unparsed*)))
    (set! *unparsed* (cdr *unparsed*))
    found-type))

(define (parse-binary)
  (list 'binary
	(parse-simple-expression)
	(parse-type 'oper)
	(parse-expression)))

(define (parse-chunk)
  (list 'chunk
	(parse-type 'open-paren)
	(parse-expression)
	(parse-type 'close-paren)))

(define (parse-function)
  (list 'function
	(parse-type 'variable)
	(parse-chunk)))

(define (parse-simple-expression)
  (amb (parse-type 'number)
       (parse-type 'variable)
       (parse-chunk)
       (parse-function)))

(define (parse-expression)
  (amb (parse-type 'number)
       (parse-type 'variable)
       (parse-binary)
       (parse-chunk)
       (parse-function)))

(define (parse-infix in)
  (set! *unparsed* (listify in))
  (let ((sent (parse-expression)))
    (require (null? *unparsed*))
    sent))

#| Test:
;;; Amb-Eval input:
(parse-infix "sqrt(5+square(4*4))")

;;; Starting a new problem 
;;; Amb-Eval value:
Number of alts considered: 99
(function
 (variable "sqrt")
 (chunk
  (open-paren "(")
  (binary
   (number "5")
   (oper "+")
   (function
    (variable "square")
    (chunk (open-paren "(")
           (binary (number "4") (oper "*") (number "4"))
           (close-paren ")"))))
  (close-paren ")")))

;;; Amb-Eval input:
(parse-infix "1+2+4+5")

;;; Starting a new problem 
;;; Amb-Eval value:
Number of alts considered: 13
(binary
 (number "1")
 (oper "+")
 (binary (number "2")
         (oper "+")
         (binary (number "4") (oper "+") (number "5"))))

|#

(define (lispify parsed)
  (cond ((eq? (car parsed) 'function)
	 (list (lispify (car (cdr parsed)))
	       (lispify (car (cdr (cdr parsed))))))
	((eq? (car parsed) 'variable)
	 (string->symbol (car (cdr parsed))))
	((eq? (car parsed) 'number)
	 (string->number (car (cdr parsed))))
	((eq? (car parsed) 'binary)
	 (list (lispify (car (cdr (cdr parsed))))
	       (lispify (car (cdr parsed)))
	       (lispify (car (cdr (cdr (cdr parsed)))))))
	((eq? (car parsed) 'chunk)
	 (lispify (car (cdr (cdr parsed)))))
	((eq? (car parsed) 'oper)
	 (string->symbol (car (cdr parsed))))
	(else (error "Unhandled type: " (car parsed)))))

; note, this requres eval-in-amb to be defined in the top level
(define (infix in)
  (eval-in-amb (lispify (parse-infix in))))

#|
; x needs to be defined in the top level; here it's 5

;;; Amb-Eval input:
(infix "sqrt(4+3/x*square(56 - 83))")

;;; Starting a new problem 
;;; Amb-Eval value:
Number of alts considered: 146
2.0002057507335316

|#