PageRenderTime 76ms CodeModel.GetById 23ms RepoModel.GetById 0ms app.codeStats 0ms

/clojure/section4.2/src/section4.clj

http://github.com/jakemcc/sicp-study
Clojure | 491 lines | 367 code | 108 blank | 16 comment | 38 complexity | cdbfb0f7a55010358c5641a17ab79e0b MD5 | raw file
  1. (ns section4
  2. (:use scheme-helpers
  3. environment))
  4. (declare execute-application
  5. primitive-procedure-names
  6. primitive-procedure-objects
  7. my-eval
  8. my-apply
  9. analyze
  10. no-operands?
  11. first-operand
  12. rest-operands
  13. actual-value)
  14. ; Exercise 4.1
  15. (defn list-of-values [exps env]
  16. (if (no-operands? exps)
  17. '()
  18. (let [left (my-eval (first-operand exps) env)
  19. right (list-of-values (rest-operands exps) env)]
  20. (cons left right))))
  21. ; Above function imposes a left to right ordering. If the
  22. ; assignments inside of let where switched it would be right
  23. ; to left
  24. (declare if-predicate if-alternative if-consequent)
  25. (defn eval-if [exp env]
  26. (if (actual-value (if-predicate exp) env)
  27. (my-eval (if-consequent exp) env)
  28. (my-eval (if-alternative exp) env)))
  29. (declare last-exp? first-exp rest-exps)
  30. (defn eval-sequence [exps env]
  31. (cond (last-exp? exps) (my-eval (first-exp exps) env)
  32. :else (do (my-eval (first-exp exps) env)
  33. (eval-sequence (rest-exps exps) env))))
  34. ;make above a recur
  35. (declare assignment-variable assignment-value)
  36. (defn eval-assignment [exp env]
  37. (set-variable-value! (assignment-variable exp)
  38. (my-eval (assignment-value exp) env)
  39. env)
  40. 'ok)
  41. (declare definition-variable definition-value)
  42. (defn eval-definition [exp env]
  43. ; (println "eval-def: " exp)
  44. (define-variable!
  45. (definition-variable exp)
  46. (my-eval (definition-value exp) env)
  47. env)
  48. 'ok)
  49. (defn self-evaluating? [exp]
  50. (or (number? exp)
  51. (string? exp)
  52. (and (seq? exp) (self-evaluating? (first exp)))))
  53. (defn variable? [exp]
  54. (or (symbol? exp)
  55. (= 'true exp)
  56. (= 'false exp)))
  57. (defn tagged-list? [exp tag]
  58. (if (seq? exp)
  59. (= (first exp) tag)
  60. false))
  61. (defn quoted? [exp]
  62. (tagged-list? exp 'quote))
  63. (defn text-of-quotation [exp] (cadr exp))
  64. (defn assignment? [exp]
  65. (tagged-list? exp 'set!))
  66. (defn assignment-variable [exp] (second exp))
  67. (defn assignment-value [exp] (nth exp 2))
  68. (defn definition? [exp]
  69. (tagged-list? exp 'define))
  70. (defn definition-variable [exp]
  71. (if (symbol? (second exp))
  72. (second exp)
  73. (first (first (rest exp)))))
  74. (declare make-lambda)
  75. (defn definition-value [exp]
  76. (if (symbol? (second exp))
  77. (nth exp 2)
  78. (make-lambda (rest (first (rest exp))) ; formal parameters
  79. (rest (rest exp))))) ; body
  80. (defn lambda? [exp] (tagged-list? exp 'lambda))
  81. (defn lambda-parameters [exp] (second exp))
  82. (defn lambda-body [exp] (rest (rest exp)))
  83. (defn make-lambda [parameters body]
  84. (cons 'lambda (cons parameters body)))
  85. (defn if? [exp] (tagged-list? exp 'if))
  86. (defn if-predicate [exp] (cadr exp))
  87. (defn if-consequent [exp] (caddr exp))
  88. (defn if-alternative [exp]
  89. (if (not (nil? (cdddr exp)))
  90. (cadddr exp)
  91. 'false))
  92. (defn make-if [predicate consequent alternative]
  93. (list 'if predicate consequent alternative))
  94. (defn begin? [exp] (tagged-list? exp 'begin))
  95. (defn begin-actions [exp] (cdr exp))
  96. (defn last-exp? [xs] (null? (cdr xs)))
  97. (defn first-exp [xs] (car xs))
  98. (defn rest-exps [xs] (cdr xs))
  99. (defn make-begin [xs] (cons 'begin xs))
  100. (defn sequence->exp [xs]
  101. (cond (null? xs) xs
  102. (last-exp? xs) (first-exp xs)
  103. :else (make-begin xs)))
  104. (defn pair? [x] (seq? x))
  105. (defn application? [exp] (pair? exp))
  106. (defn operator [exp] (car exp))
  107. (defn operands [exp] (cdr exp))
  108. (defn no-operands? [ops] (null? ops))
  109. (defn first-operand [ops] (car ops))
  110. (defn rest-operands [ops] (cdr ops))
  111. (declare expand-clauses)
  112. (defn cond? [exp] (tagged-list? exp 'cond))
  113. (defn cond-clauses [exp] (cdr exp))
  114. (defn cond-predicate [clause] (car clause))
  115. (defn cond-else-clause? [clause]
  116. (= (cond-predicate clause) 'else))
  117. (defn cond-actions [clause] (cdr clause))
  118. (defn cond->if [exp]
  119. (expand-clauses (cond-clauses exp)))
  120. (defn extended-cond? [clause]
  121. (and (list? clause)
  122. (> (count clause) 2)
  123. (= (second clause) '=>)))
  124. (defn extended-cond-test [clause]
  125. (first clause))
  126. (defn extended-cond-recipient [clause]
  127. (nth clause 2))
  128. (defn expand-clauses [clauses]
  129. (if (null? clauses)
  130. 'false
  131. (let [first-clause (car clauses)
  132. rest-clauses (cdr clauses)]
  133. (cond (cond-else-clause? first-clause)
  134. (if (null? rest-clauses)
  135. (sequence->exp (cond-actions first-clause))
  136. (Error. (str "ELSE clause isn't last -- COND->IF"
  137. clauses)))
  138. (extended-cond? first-clause)
  139. (make-if (extended-cond-test first-clause)
  140. (list
  141. (extended-cond-recipient first-clause)
  142. (extended-cond-test first-clause))
  143. (expand-clauses rest-clauses))
  144. :else
  145. (make-if (cond-predicate first-clause)
  146. (sequence->exp (cond-actions first-clause))
  147. (expand-clauses rest-clauses))))))
  148. (declare scan-out-defines)
  149. (defn make-procedure [parameters body env]
  150. (list 'procedure parameters (scan-out-defines body) env))
  151. (defn compound-procedure? [p]
  152. (tagged-list? p 'procedure))
  153. (defn procedure-parameters [p] (cadr p))
  154. (defn procedure-body [p] (caddr p))
  155. (defn procedure-environment [p] (cadddr p))
  156. (defn let? [exp]
  157. (tagged-list? exp 'let))
  158. (defn named-let? [exp]
  159. (symbol? (second exp)))
  160. (defn let-body [exp]
  161. (if (named-let? exp)
  162. (nth exp 3)
  163. (nth exp 2)))
  164. (defn let-variables [exp]
  165. (if (named-let? exp)
  166. (map first (nth exp 2))
  167. (map first (second exp))))
  168. (defn let-values [exp]
  169. (if (named-let? exp)
  170. (map second (nth exp 2))
  171. (map second (second exp))))
  172. (defn let-name [exp]
  173. (second exp))
  174. (defn make-definition [fn-name parameters body]
  175. (list 'define (cons fn-name parameters) body))
  176. ; define function
  177. ; eval function with arguments
  178. (defn let->combination [exp]
  179. (let [parameters (let-variables exp)
  180. args (let-values exp)
  181. body (let-body exp)]
  182. (if (named-let? exp)
  183. (sequence->exp
  184. (list
  185. (make-definition (let-name exp)
  186. parameters
  187. body)
  188. (cons
  189. (let-name exp)
  190. args)))
  191. (cons
  192. (make-lambda (let-variables exp)
  193. (list (let-body exp)))
  194. (let-values exp)))))
  195. (defn let*? [exp]
  196. (tagged-list? exp 'let*))
  197. (defn make-let [clauses body]
  198. (list 'let clauses body))
  199. (defn let*->nested-lets [exp]
  200. (let [let-clauses (reverse (second exp))
  201. body (let-body exp)]
  202. (reduce #(make-let (list %2) %1) body let-clauses)))
  203. (def primitive-procedures
  204. (list (list 'car car)
  205. (list 'cdr cdr)
  206. (list 'cadr cadr)
  207. (list 'cons cons)
  208. (list 'null? null?)
  209. (list '+ +)
  210. (list '- -)
  211. (list '* *)
  212. (list '/ /)
  213. (list '= =)
  214. (list '> >)
  215. (list '< <)
  216. (list 'and (fn [& xs] (reduce #(and %1 %2) true xs)))
  217. (list 'or (fn [& xs] (reduce #(or %1 %2) false xs)))))
  218. (defn primitive-procedure-names []
  219. (map car primitive-procedures))
  220. (defn primitive-procedure-objects []
  221. (map (fn [proc] (list 'primitive (cadr proc)))
  222. primitive-procedures))
  223. (defn setup-environment []
  224. (let [initial-env
  225. (extend-environment (primitive-procedure-names)
  226. (primitive-procedure-objects)
  227. the-empty-environment)]
  228. (define-variable! 'true true initial-env)
  229. (define-variable! 'false false initial-env)
  230. (define-variable! 'nil nil initial-env)
  231. initial-env))
  232. (def the-global-environment (setup-environment))
  233. (defn reset-global-environment []
  234. (def the-global-environment (setup-environment)))
  235. ; Exercise 4.13
  236. (defn unbind? [exp]
  237. (tagged-list? exp 'make-unbound!))
  238. (defn eval-unbind [exp env]
  239. (unbind-variable! (second exp) env)
  240. 'ok)
  241. (defn primitive-procedure? [proc]
  242. (tagged-list? proc 'primitive))
  243. (defn primitive-implementation [proc] (cadr proc))
  244. (defn apply-primitive-procedure [proc args]
  245. (apply (primitive-implementation proc) args))
  246. (defn execute-application [proc args]
  247. (cond (primitive-procedure? proc)
  248. (apply-primitive-procedure proc args)
  249. (compound-procedure? proc)
  250. ((procedure-body proc)
  251. (extend-environment (procedure-parameters proc)
  252. args
  253. (procedure-environment proc)))
  254. :else
  255. (Error. (str
  256. "Unknown procedure type -- EXECUTE-APPLICATION"
  257. proc))))
  258. (defn is-define? [e]
  259. (and (seq? e)
  260. (tagged-list? e 'define)))
  261. (defn find-defines [exp]
  262. (filter is-define? exp))
  263. (defn defined-variables [defs]
  264. (map second defs))
  265. (defn defined-values [defs]
  266. (map #(nth % 2) defs))
  267. (defn non-defines [exp]
  268. (remove is-define? exp))
  269. (defn scan-out-defines [exp]
  270. (let [defs (find-defines exp)]
  271. (if (zero? (count defs))
  272. exp
  273. (let [variables (defined-variables defs)
  274. values (defined-values defs)
  275. body (nth (non-defines exp) 2)
  276. vars (second (non-defines exp))]
  277. (list 'lambda
  278. vars
  279. (cons 'let
  280. (cons (map #(list % (quote (quote *unassigned*))) variables)
  281. (concat (map
  282. #(list 'set! %1 %2)
  283. variables
  284. values)
  285. (list body)))))))))
  286. ; Exercise 4.20
  287. (defn letrec? [exp]
  288. (tagged-list? exp 'letrec))
  289. (defn letrec->let [exp]
  290. (let [fns (second exp)
  291. fn-names (map first fns)
  292. fn-vals (map second fns)
  293. body (nth exp 2)]
  294. (make-let
  295. (map #(list % ''*unassigned*) fn-names)
  296. (make-begin
  297. (concat
  298. (map #(list 'set! %1 %2) fn-names fn-vals)
  299. (list body))))))
  300. (defrecord Thunk [exp env])
  301. (defrecord Evaluated-Thunk [value])
  302. (defn atom? [x]
  303. (= clojure.lang.Atom (class x)))
  304. (defn thunk? [obj]
  305. ; (println "thunk? " obj " " (type obj) (atom? obj))
  306. (if (atom? obj)
  307. (= Thunk (class @obj))
  308. false))
  309. (defn delay-it [exp env]
  310. (atom (Thunk. exp env)))
  311. (defn evaluated-thunk? [obj]
  312. (if (atom? obj)
  313. (= Evaluated-Thunk (class @obj))))
  314. (defn make-evaled-thunk [old-thunk new-value]
  315. (Evaluated-Thunk. new-value))
  316. (defn force-it [obj]
  317. ; (println "force-it: " obj)
  318. (cond
  319. (thunk? obj)
  320. (let [result (actual-value (:exp @obj)
  321. (:env @obj))]
  322. (swap! obj make-evaled-thunk result)
  323. result)
  324. (evaluated-thunk? obj) (:value @obj)
  325. :else obj))
  326. (defn actual-value [exp env]
  327. ; (println "Actual value: " exp)
  328. (let [actual (my-eval exp env)
  329. forced (force-it actual)]
  330. ; (println "forced: " forced)
  331. forced))
  332. (defn list-of-arg-values [exp env]
  333. ; (println "list-of-arg-values: " exp)
  334. (if (no-operands? exp)
  335. '()
  336. (cons (actual-value (first-operand exp) env)
  337. (list-of-arg-values (rest-operands exp)
  338. env))))
  339. (defn list-of-delayed-args [exps env]
  340. (if (no-operands? exps)
  341. '()
  342. (cons (delay-it (first-operand exps) env)
  343. (list-of-delayed-args (rest-operands exps)
  344. env))))
  345. (defn my-eval [exp env]
  346. (cond (self-evaluating? exp) exp
  347. (variable? exp) (lookup-variable-value exp env)
  348. (quoted? exp) (text-of-quotation exp)
  349. (assignment? exp) (eval-assignment exp env)
  350. (unbind? exp) (eval-unbind exp env)
  351. (definition? exp) (eval-definition exp env)
  352. (if? exp) (eval-if exp env)
  353. (lambda? exp)
  354. (make-procedure (lambda-parameters exp)
  355. (lambda-body exp)
  356. env)
  357. (begin? exp)
  358. (eval-sequence (begin-actions exp) env)
  359. (cond? exp) (my-eval (cond->if exp) env)
  360. (let? exp) (my-eval (let->combination exp) env)
  361. (let*? exp) (my-eval (let*->nested-lets exp) env)
  362. (letrec? exp) (my-eval (letrec->let exp) env)
  363. (application? exp)
  364. (my-apply (actual-value (operator exp) env)
  365. (operands exp)
  366. env)
  367. :else (Error. (str "Unknown expression type -- EVAL " exp))))
  368. (defn my-apply [procedure arguments env]
  369. ; (println "apply: " procedure " " arguments)
  370. (cond (primitive-procedure? procedure)
  371. (apply-primitive-procedure
  372. procedure
  373. (list-of-arg-values arguments env))
  374. (compound-procedure? procedure)
  375. (eval-sequence
  376. (procedure-body procedure)
  377. (extend-environment
  378. (procedure-parameters procedure)
  379. (list-of-delayed-args arguments env)
  380. (procedure-environment procedure)))
  381. :else (Error. (str "Unknown procedure type -- APPLY " procedure))))
  382. (defn interpret [exp]
  383. (actual-value exp the-global-environment))