├── .gitignore ├── land-of-lisp ├── city.png ├── known-city.png ├── wizard-graph.dot.png ├── wizard-graph-undirected.dot.png ├── cap6.5-lambda.lisp ├── example.svg ├── cap2-guess-my-number.lisp ├── cap12-socket-client.lisp ├── cap20-dice-of-doom-v4.lisp ├── cap12-socket-server.lisp ├── cap6-reading-and-printing.lisp ├── cap17-text-game-adventure-v2.lisp ├── cap10-loop.lisp ├── cap11-attack-of-the-robots.lisp ├── cap13-error-handling.lisp ├── cap14-functional-programming.lisp ├── cap18-lazy-programming.lisp ├── cap16-magic-with-macros.lisp ├── cap17-domain-specific-languages.lisp ├── cap12-streams.lisp ├── cap13-webserver.lisp ├── cap10-life-simulation.lisp ├── cap7-beyond-basic-lists.lisp ├── cap19-web-dice-of-doom-v3.lisp ├── cap18-dice-of-doom-v2.lisp ├── cap9-advanced-generic-programming.lisp ├── cap9-orc-battle-game.lisp ├── cap5-building-a-text-game-engine.lisp ├── cap8-neowumpus.lisp ├── cap4-conditionals.lisp └── cap11-format.lisp ├── random ├── namespaces-troll.lisp ├── command-line-args.lisp ├── compose.lisp └── game-of-life-sdl.lisp ├── mit-6.001 ├── 6B-streams-II.lisp ├── 2A-lambda-expressions.lisp ├── 1B-iterative-vs-recursive.lisp ├── 5A-state-and-side-effects.lisp ├── 1A-heuristic-square-root.lisp ├── 8B-logic-programming-II.lisp ├── 3B-symbolic-differentiation.lisp ├── 2B-compund-data.lisp ├── 9A-register-machines.lisp ├── 8A-logic-programming-I.lisp ├── 10B-storage-allocation-and-garbage-collector.lisp ├── 4B-generic-operators.lisp ├── 10A-compilation.lisp ├── 3A-data-abstraction.lisp ├── 7A-metacircular-evaluator-I.lisp ├── 5B-computational-objects.lisp ├── 9B-explicit-control-evaluator.lisp ├── 6A-streams-I.lisp ├── 4A-pattern-matching.lisp └── 7B-metacircular-evaluator-II.lisp ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.FASL 2 | *.fasl 3 | *.lisp-temp 4 | -------------------------------------------------------------------------------- /land-of-lisp/city.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ryukinix/lisp-insights/HEAD/land-of-lisp/city.png -------------------------------------------------------------------------------- /land-of-lisp/known-city.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ryukinix/lisp-insights/HEAD/land-of-lisp/known-city.png -------------------------------------------------------------------------------- /land-of-lisp/wizard-graph.dot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ryukinix/lisp-insights/HEAD/land-of-lisp/wizard-graph.dot.png -------------------------------------------------------------------------------- /land-of-lisp/wizard-graph-undirected.dot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ryukinix/lisp-insights/HEAD/land-of-lisp/wizard-graph-undirected.dot.png -------------------------------------------------------------------------------- /random/namespaces-troll.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (flet ((foo (when funcall) 5 | (when (< 3 when) 6 | (funcall funcall)) when)) 7 | (loop :named funcall :for funcall :from 1 :collect 8 | (foo funcall (lambda () (loop-finish))))) -------------------------------------------------------------------------------- /random/command-line-args.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/bin/sbcl 2 | ;; Common Lisp Script 3 | ;; Manoel Vilela 4 | 5 | (defun my-command-line () 6 | (or 7 | #+SBCL sb-ext:*posix-argv* 8 | #+CLISP *args* 9 | #+LISPWORKS system:*line-arguments-list* 10 | #+CMU extensions:*command-line-words* 11 | nil)) 12 | 13 | (format t "~&~S~&" (my-command-line)) -------------------------------------------------------------------------------- /land-of-lisp/cap6.5-lambda.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; simple lambda usage with mapcar 5 | (mapcar (lambda (x) (/ x 2)) '(1 2 3 4)) ;; => (1/2 1 3/2 2) 6 | 7 | ;; is equivalent 8 | (defun half (x) 9 | (/ x 2)) 10 | 11 | (mapcar #'half '(1 2 3 4)) 12 | 13 | ;; lambda' are a macro, so your operands are not evaluated first 14 | -------------------------------------------------------------------------------- /land-of-lisp/example.svg: -------------------------------------------------------------------------------- 1 | 2 | 6 | 7 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /random/compose.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defun compose (&rest funs) 5 | (let ((funs (reverse funs))) 6 | (lambda (&rest args) 7 | (loop with result = args 8 | for fun in funs 9 | do (setf result (list (apply fun result))) 10 | finally (return (car result)))))) 11 | 12 | (funcall (compose #'abs #'-) 1 2) #| ==> 1 |# -------------------------------------------------------------------------------- /land-of-lisp/cap2-guess-my-number.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defun guess-my-number () 5 | (ash (+ *small* *big*) -1)) 6 | 7 | (defun smaller () 8 | (setf *big* (1- (guess-my-number))) 9 | (guess-my-number)) 10 | 11 | (defun bigger () 12 | (setf *small* (1+ (guess-my-number))) 13 | (guess-my-number)) 14 | 15 | (defun start-over () 16 | (defparameter *small* 1) 17 | (defparameter *big* 100) 18 | (guess-my-number)) 19 | -------------------------------------------------------------------------------- /mit-6.001/6B-streams-II.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (load "6A-streams-I.lisp") 5 | 6 | 7 | ;; i just watched this lecture, some behaviors of stream don't works well here 8 | ;; i can't define things like (define ones (cons-stream 1 ones)) 9 | ;; the primitive for streams on previous lecture is messed up 10 | ;; the problem is store a operand of procedure without evaluated it before 11 | ;; as common lisp eval all your operands before doing a funcall, 12 | ;; delay procedure doesn't works well. 13 | -------------------------------------------------------------------------------- /land-of-lisp/cap12-socket-client.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (ql:quickload 'usocket) 5 | 6 | (princ "CLIENT: Trying connect to server... ") 7 | (defparameter *socket-connection* (usocket:socket-connect "127.0.0.1" 1234)) 8 | (defparameter *socket-stream* (usocket:socket-stream *socket-connection*)) 9 | (format t "Connected! ~%") 10 | 11 | (write-line "Yo Server!" *socket-stream*) 12 | (finish-output *socket-stream*) ;; force send messaging 13 | (format t ": ~a ~%" (read-line *socket-stream*)) 14 | 15 | (usocket:socket-close *socket-connection*) 16 | -------------------------------------------------------------------------------- /mit-6.001/2A-lambda-expressions.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; function Σ 5 | ;; func must be a lambda(x) expression 6 | (defun Σ (λ a b &optional (next #'1+)) 7 | (if (> a b) 8 | 0 9 | (+ (funcall λ a) 10 | (Σ λ (funcall next a) b)))) 11 | 12 | ;; I would like to avoid the use of 'funcall' for calling 13 | ;; lambda expressions passed to Σ, is ugly. 14 | 15 | (defun sum-square (a b) 16 | (Σ #'(lambda(x) (* x x)) a b)) 17 | 18 | (defun sum-int (a b) 19 | (Σ #'(lambda(x) x) a b)) 20 | 21 | (defun sum-pi (a b) 22 | (Σ #'(lambda (x) (/ 1 (* x (+ 1 2)))) 23 | a b 24 | #'(lambda (x) (+ x 4)))) 25 | 26 | (sum-square 1 10) 27 | (sum-int 1 10) 28 | (Σ #'(lambda(x) (/ 1 x)) 1 10 #'(lambda (x) (+ 4 x))) 29 | (Σ #'(lambda(x) (- x)) 1 10) -------------------------------------------------------------------------------- /mit-6.001/1B-iterative-vs-recursive.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defun print-eval (expression) 5 | (eval (print expression))) 6 | 7 | ;; linear iterative solution 8 | ;; time=O(x); space=O(1) 9 | (defun sum-i (x y) 10 | (if (= x 0) 11 | y 12 | (print-eval `(sum-i (1- ,x) (1+ ,y))))) 13 | 14 | 15 | ;; linear recursive solution 16 | ;; time=O(x); space=O(x) 17 | ;; but lisp have tail call optimization 18 | ;; so we receive the same of sum-i on printing 19 | (defun sum-r (x y) 20 | (if (= x 0) 21 | y 22 | (print-eval `(1+ (sum-r (1- ,x) ,y))))) 23 | 24 | 25 | (defun fib-r (n) 26 | (if (< n 2) 27 | n 28 | (print-eval `(+ (fib-r (- ,n 1)) 29 | (fib-r (- ,n 2)))))) 30 | 31 | (print (sum-i 10 20)) 32 | (print (sum-r 10 20)) 33 | (print (fib-r 10)) -------------------------------------------------------------------------------- /land-of-lisp/cap20-dice-of-doom-v4.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defpackage :dice-of-doom-v4 5 | (:use :cl :dice-of-doom-v3)) 6 | 7 | (in-package :dice-of-doom-v4) 8 | 9 | 10 | ;; YES, MORE PLAYERS 11 | (defparameter *num-players* 4) 12 | (defparameter *die-colors* '((255 63 63) (63 63 255) (63 255 63) 13 | (255 63 255))) 14 | (defparameter *max-dice* 5) 15 | (defparameter *ai-level* 2) 16 | 17 | #| 18 | 19 | LISP OVERHEAT 20 | 21 | I'm tired of this shit example of DICE OF DOOM! THIS IS NOT FUN. 22 | 23 | Go to hell web-based games. 24 | 25 | |# 26 | 27 | ;; NOTE: Skipping this chapter. I'll note write a new version of Dice of Doom! Holy crap, 28 | ;; four versions of a stupid game?! NOOOO!. I will do something more useful. 29 | 30 | ;; BTW, this shit style to redefining functions and using package of earlier versions is 31 | ;; a absolutely hell. If you wanna write something great, start writing the great thing first. 32 | ;; REDEFINING AND MIXING-UP IS EVIL. 33 | -------------------------------------------------------------------------------- /land-of-lisp/cap12-socket-server.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (ql:quickload 'usocket) 5 | 6 | ;; NOTE: in that example i need to force the stream with (finish-output) 7 | ;; to effectively send messages between sockets. 8 | 9 | ;; listening socket 10 | (defparameter *my-socket* (usocket:socket-listen "127.0.0.1" 1234)) 11 | 12 | (princ "SERVER: Waiting client connection... ") 13 | (finish-output) 14 | (defparameter *socket-connection* (usocket:socket-accept *my-socket*)) 15 | (defparameter *socket-stream* (usocket:socket-stream *socket-connection*)) 16 | (format t "Connected! ~%") 17 | ;; after running this command, the server will seem to lock up, 18 | ;; and you won't be returned to the REPL prompt. 19 | ;; Don't be alarmed, the socket-accept command is a blocking operation, 20 | ;; which means the function won't exit until a client has connected. 21 | 22 | (format t ": ~a ~%" (read-line *socket-stream*)) 23 | (write-line "What's up, Client!" *socket-stream*) 24 | (finish-output *socket-stream*) ;; flush buffered stream 25 | (usocket:socket-close *my-socket*) 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Manoel Vilela 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /mit-6.001/5A-state-and-side-effects.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; mathematical truths using functional programming 5 | ;; don't change state, the same funcall for same params 6 | ;; the result is the same 7 | 8 | (defun fact (n) 9 | (if (<= n 1) 10 | 1 11 | (* n (fact (1- n))))) 12 | 13 | ;; imperative way 14 | (defun fact (n) 15 | (let ((i 1) 16 | (m 1)) 17 | (labels ((iter () 18 | (if (> i n) 19 | m 20 | (progn (setq m (* i m)) 21 | (setq i (1+ i)) 22 | (iter))))) 23 | (iter)))) 24 | 25 | (fact 10) 26 | 27 | ;; using mutation of state 28 | ;; lambda used as closure 29 | (defun make-counter (n) 30 | (lambda () 31 | (setq n (1+ n)) 32 | n)) 33 | 34 | (setf (symbol-function 'c1) (make-counter 1)) 35 | (setf (symbol-function 'c2) (make-counter 10)) 36 | (c1) ;; independents states for n 37 | (c2) ;; makes change on our environment 38 | 39 | ;; examples with free variable 40 | 41 | (defun free-variable-x () 42 | (lambda (x) (lambda (y) (* x y)))) 43 | ;; ↑ x is a free-variable get in the environment at that moment 44 | -------------------------------------------------------------------------------- /land-of-lisp/cap6-reading-and-printing.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; fundamentals printing 5 | 6 | ;; :: print 7 | ;; print send the arg to sdout with #\newline before the sentence 8 | ;; and add on the end a white-space too LOL something like that: 9 | ;; (format t "~% ~s " 'simbol) ;; realy crazy!!!! 10 | ;; and return the output 11 | (print 'abacate) 12 | (print '(some data)) 13 | (print ':this-is-a-keyword) 14 | (print "that is a string") 15 | 16 | ;; :: prin1 17 | ;; same thing of the 'print' function, but return a space 18 | ;; instead newline 19 | (progn (prin1 "1") 20 | (prin1 "2") 21 | (prin1 "3")) 22 | 23 | ;; simple example combining things 24 | ;; remember: read sucks 25 | ;; read operator only reads a single token. 26 | ;; if you type two tokens will break 27 | (defun say-hello () 28 | (print "Please type your name: ") 29 | (let ((name (read))) 30 | (prin1 "Nice to meet you, ") 31 | (prin1 name))) 32 | (say-hello) 33 | 34 | ;; but print and prin1 is repl stuff, don't cool for humans 35 | ;; print strings with quotes and had a print esoteric behavior of newline-content-space 36 | ;; instead use that, use princ! and read-line 37 | 38 | (progn (princ "An weird way to") 39 | (princ #\newline) 40 | (princ "To split a phrase")) 41 | 42 | (defun say-hello ()q 43 | (princ "Please type your name: ") 44 | (let ((name (read-line))) ;; read-line is nice! 45 | (princ "Nice to meet you, ") 46 | (princ name))) 47 | 48 | ;; other examples for princ 49 | (princ :foo) 50 | (princ 1.2) 51 | (princ "object") 52 | (princ 2/3) 53 | (princ 'symbol) 54 | -------------------------------------------------------------------------------- /mit-6.001/1A-heuristic-square-root.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | #| A heuristic method to calculate the 5 | square root of a number x based on the 6 | Hero of Alexandria's alogrithm. 7 | |# 8 | 9 | 10 | (defparameter *error-limit* 0.001) 11 | 12 | (defparameter *tests* '((square-root 2) 13 | (square-root 12) 14 | (square-root 25) 15 | (square-root 144) 16 | (square-root 165465) 17 | )) 18 | 19 | (defun square (x) 20 | (* x x)) 21 | 22 | (defun average (x y) 23 | (/ (+ x y) 2)) 24 | 25 | ;; square-root black box 26 | ;; functional by function composition 27 | (defun square-root (x &key (error-limit *error-limit*)) 28 | (labels ((improve (guess) 29 | (average guess (/ x guess))) 30 | (good-enough? (guess) 31 | (< (abs (- (square guess) x)) 32 | error-limit)) 33 | (try (guess) 34 | (if (good-enough? guess) 35 | guess 36 | (try (improve guess))))) 37 | 38 | (float (try 1)))) 39 | 40 | 41 | ;; eval-test black-box 42 | ;; functional 43 | (defun eval-test (test fn limit) 44 | (labels ((call-test (test) 45 | (let ((output (eval test))) 46 | (format t "~s -> ~f ~%" test output) 47 | output))) 48 | (let ((x (cadr test))) 49 | (if (< (abs (- (call-test test) (funcall fn x))) 50 | limit) 51 | :nice 52 | :fail)))) 53 | 54 | ;; non-functional use variable global *error-limit* and *tests* 55 | (defun run-tests () 56 | (format t "Running tests with limit ~f ~%" *error-limit*) 57 | (let* ((results (loop for x in *tests* collect (eval-test x #'sqrt *error-limit*))) 58 | (total (length results)) 59 | (pass (count :nice results))) 60 | (format t "Tests avalied [pass/total]: ~d/~d ~%" pass total))) 61 | 62 | 63 | (run-tests) 64 | -------------------------------------------------------------------------------- /land-of-lisp/cap17-text-game-adventure-v2.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (load "cap5-building-a-text-game-engine") 5 | 6 | 7 | (defun have (object) 8 | (member object (inventory))) 9 | 10 | (defparameter *chain-welded* nil) 11 | 12 | (defun weld (subject object) 13 | (if (and (eq *location* 'attic) 14 | (eq subject 'chain) 15 | (eq object 'bucket) 16 | (have 'chain) 17 | (have 'bucket) 18 | (not *chain-welded*)) 19 | (progn (setf *chain-welded* t) 20 | '(the chain is now securely welded to the bucket.)) 21 | '(you cannot weld like that.))) 22 | 23 | (pushnew 'weld *allowed-commands*) 24 | (defparameter *bucket-filled* nil) 25 | 26 | (defun dunk (subject object) 27 | (if (and (eq *location* 'garden) 28 | (eq subject 'bucket) 29 | (eq object 'well) 30 | (have 'bucket) 31 | *chain-welded*) 32 | (progn (setf *bucket-filled* t) 33 | '(the bucket is now full of water)) 34 | '(you cannot dunk like that))) 35 | (pushnew 'dunk *allowed-commands*) 36 | 37 | 38 | ;; super cool macro to avoid replication like the commands above 39 | (defmacro game-action (command subj obj place &body body) 40 | `(progn (defun ,command (subject object) 41 | (if (and (eq *location* ',place) 42 | (eq subject ',subj) 43 | (eq object ',obj) 44 | (have ',subj)) 45 | ,@body 46 | '(i cant ,command like that.))) 47 | (pushnew ',command *allowed-commands*))) 48 | 49 | (game-action splash bucket wizard living-room 50 | (cond ((not *bucket-filled*) '(the bucket has nothing in it.)) 51 | ((have 'frog) '(the wizard awakens and sees that you stole his frog. 52 | he is so upset he banishes you to the netherworlds- 53 | you lose! the end.)) 54 | (t '(the wizard awakens from his slumber and greets your warmly. 55 | he hands you the magic low-carb donut- you win! the end.)))) 56 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # lisp-insights 2 | A personal repository for annotation about learning lisp patterns. 3 | The current content are answers plus code covering of the book [Land of Lisp](http://www.landoflisp.com) and the insights at the MIT 6.001 Course: Structures and Interpretations of Computer Programs. 4 | 5 | 6 | # Land of Lisp book (reading) [482/482] 7 | 8 | - [x] Section I: Lisp is Power 9 | - [x] Chapter 1 (intro) 10 | - [x] Chapter 2 (guess my numbers) 11 | - [x] Chapter 3 (exploring syntax of lisp) 12 | - [x] Section II: Lisp is Symmetry 13 | - [x] Chapter 4 (conditionals) 14 | - [x] Chapter 5 (building a text game engine) 15 | - [x] Chapter 6 (printing files) 16 | - [x] Chapter 6.5 (lambda chapter) 17 | - [x] Chapter 7 (go beyond basic lists) 18 | - [x] Chapter 8 (grand theft wumpus) 19 | - [x] Chapter 9 (advanced datatypes and generic programming) 20 | - [x] Section III: Lisp is Hacking 21 | - [x] Chapter 10 (looping with the loop command) 22 | - [x] Chapter 11 (printing with the format function) 23 | - [x] Chapter 12 (working with streams) 24 | - [x] Chapter 13 (let's create a web server -- agh :<) 25 | - [x] Section IV: Lisp is Science 26 | - [x] Chapter 14 (Ramping lisp up a Notch with Functional Programming) 27 | - [x] Chapter 15 (Dice of Doom, a Game Written in the Functional Style) 28 | - [x] Chapter 16 (The Magic of Lisp Macros) 29 | - [x] Chapter 17 (Domain-Specific Languages) 30 | - [x] Chapter 18 (Lazy Programming) 31 | - [x] Chapter 19 (Creating a Graphical, Web-Based Version of Dice of Doom) 32 | - [x] Chapter 20 (Making Dice of Doom More Fun) 33 | - [x] Epilogue (the lisp dialects and lisp techniques) 34 | 35 | 36 | # [MIT 6.001 Structures and Interpretations of Computer Programs](https://www.youtube.com/watch?v=2Op3QLzMgSY&list=PLE18841CABEA24090) 37 | 38 | - [x] Lecture 1A 39 | - [x] Lecture 1B 40 | - [x] Lecture 2A 41 | - [x] Lecture 2B 42 | - [x] Lecture 3A 43 | - [x] Lecture 3B 44 | - [x] Lecture 4A 45 | - [x] Lecture 4B 46 | - [x] Lecture 5A 47 | - [x] Lecture 5B 48 | - [x] Lecture 6A 49 | - [x] Lecture 6B 50 | - [x] Lecture 7A 51 | - [x] Lecture 7B 52 | - [x] Lecture 8A 53 | - [x] Lecture 8B 54 | - [x] Lecture 9A 55 | - [x] Lecture 9B 56 | - [x] Lecture 10A 57 | - [x] Lecture 10B 58 | -------------------------------------------------------------------------------- /land-of-lisp/cap10-loop.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; the loop macro 5 | 6 | (loop for i 7 | below 5 8 | sum i) 9 | ;; => 10 10 | 11 | 12 | ;; counting from a starting point to an ending point 13 | 14 | (loop for i 15 | from 5 16 | to 10 17 | sum i) 18 | ;; => 45 19 | 20 | ;; iterating through values in a list 21 | 22 | (loop for i 23 | in '(100 20 3) 24 | sum i) 25 | ;; => 123 26 | 27 | 28 | ;; doing stuff in a loop 29 | 30 | (loop for i 31 | below 5 32 | do (print i)) 33 | ;; => nil 34 | ;; print 0..5 on stdout 35 | 36 | ;; doing stuff under certain conditions 37 | 38 | (loop for i 39 | below 10 40 | when (oddp i) 41 | sum i) 42 | ;; => 25 43 | 44 | ;; breaking out of a loop early 45 | 46 | (loop for i 47 | from 0 48 | do (print i) 49 | when (= i 5) 50 | return 'falafel) 51 | ;; => 'FALAFEL 52 | ;; printing 0 to 5 on stdout 53 | 54 | ;; collecting a list of values 55 | (loop for i 56 | in '(2 3 4 5 6) 57 | collect (* i i)) 58 | ;; => (4 9 16 25 36) 59 | 60 | 61 | ;; using multiple for clauses 62 | 63 | (loop for x below 10 64 | for y below 10 65 | collect (+ x y)) 66 | ;; => (0 2 4 6 8 10 12 14 16 18) 67 | 68 | ;; nested loop 69 | (loop for x below 10 70 | collect (loop for y below 10 71 | collect (+ x y))) 72 | 73 | ;; => ((0 1 2 3 4 5 6 7 8 9) (1 2 3 4 5 6 7 8 9 10) 74 | ;; (2 3 4 5 6 7 8 9 10 11) (3 4 5 6 7 8 9 10 11 12) 75 | ;; (4 5 6 7 8 9 10 11 12 13) (5 6 7 8 9 10 11 12 13 14) 76 | ;; (6 7 8 9 10 11 12 13 14 15) (7 8 9 10 11 12 13 14 15 16) 77 | ;; (8 9 10 11 12 13 14 15 16 17) (9 10 11 12 13 14 15 16 17 18)) 78 | 79 | (loop for i 80 | from 0 81 | for day 82 | in '(monday tuesday wednesday thursday friday saturday sunday) 83 | collect (cons i day)) 84 | 85 | ;; => ((0 . MONDAY) (1 . TUESDAY) (2 . WEDNESDAY) 86 | ;; (3 . THURSDAY) (4 . FRIDAY) (5 . SATURDAY) (6 . SUNDAY)) 87 | 88 | 89 | ;; Well, this is just the brief introduction to loop macro on Land of Lisp. 90 | ;; The book covers this chapter with this, a periodic table-like for loop 91 | ;; with a lot of examples and on the final a life simulation. I'll cover 92 | ;; that on the next file. See you in soon. 93 | ;; EOF 94 | -------------------------------------------------------------------------------- /land-of-lisp/cap11-attack-of-the-robots.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defun robots () 5 | (loop named main 6 | with directions = '((q . -65) (w . -64) (e . -63) (a . -1) 7 | (d . 1) (z . 63) (x . 64) (c . 65)) 8 | for pos = 544 9 | then (progn (format t "~%qwe/asd/zxc to move, (t)eleport, (l)eave: ") 10 | (force-output) 11 | (let* ((c (read)) 12 | (d (assoc c directions))) 13 | (cond (d (+ pos (cdr d))) 14 | ((eq 't c) (random 1024)) 15 | ((eq 'l c) (return-from main 'bye)) 16 | (t pos)))) 17 | for monsters = (loop repeat 10 18 | collect (random 1024)) 19 | then (loop for mpos in monsters 20 | collect (if (> (count mpos monsters) 1) 21 | mpos 22 | (cdar (sort (loop for (k . d) in directions 23 | for new-mpos = (+ mpos d) 24 | collect (cons (+ (abs (- (mod new-mpos 64) 25 | (mod pos 64))) 26 | (abs (- (ash new-mpos -6) 27 | (ash pos -6)))) 28 | new-mpos)) 29 | #'< 30 | :key #'car)))) 31 | when (loop for mpos in monsters 32 | always (> (count mpos monsters) 1)) 33 | return 'player-wins 34 | do (format t 35 | "~%|~{~<|~%|~,65:;~A~>~}|" 36 | (loop for p 37 | below 1024 38 | collect (cond ((member p monsters) 39 | (cond ((= p pos) (return-from main 'player-loses)) 40 | ((> (count p monsters) 1) #\#) 41 | (t #\A))) 42 | ((= p pos) #\@) 43 | (t #\space)))))) 44 | 45 | (princ (robots)) 46 | (fresh-line) 47 | -------------------------------------------------------------------------------- /mit-6.001/8B-logic-programming-II.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; sample patterns 5 | 6 | #| 7 | 8 | (a ?x c) 9 | 10 | (job ?x (computer ?y)) 11 | 12 | (job ?x (computer . ?y)) 13 | 14 | (a ?x ?x) 15 | 16 | (?x ?y ?y ?x) 17 | 18 | (a . ?x) 19 | 20 | |# 21 | 22 | ;; rule-based system for logic programming using 23 | ;; patter matching 24 | 25 | (load "4A-pattern-matching.lisp") 26 | (match pat data dictionary) ;; needs implements match 27 | ;; in earlier lectures, the primitives for pattern matching 28 | ;; is implemented 29 | 30 | ;; query black box 31 | 32 | ;; ↓ pattern 33 | ;; +-------+ 34 | ;; | | 35 | ;; => initial-dict | QUERY | => dictionary 36 | ;; | | 37 | ;; +-------+ 38 | ;; ↑ database stream 39 | 40 | 41 | ;; means of combinations: NOT, AND, OR 42 | 43 | ;; means of abstraction: rules 44 | 45 | (rule (boss ?z ?d) 46 | (and (job ?x (?d . ?y)) 47 | (supervisor (?x ?z)))) 48 | 49 | 50 | ;; == TO APPLY A RULE 51 | 52 | ;; Evaluate the rule body relative to an environment 53 | ;; formed by unifying the rule conclusion with the 54 | ;; given query. 55 | 56 | 57 | ;; == TO APPLY A PROCEDURE 58 | 59 | ;; Evaluate the procedure body relative to an enviroment 60 | ;; formed by binding the procedure paramaters to the 61 | ;; to the arguments. 62 | 63 | 64 | ;; All humans are mortals 65 | ;; All greeks are humans. 66 | ;; Socrates is greek, 67 | ;;------ syllogism logic ---- 68 | ;; :: Socrates is mortal. 69 | 70 | 71 | (Greek Socrates) 72 | (Greek Plato) 73 | (Greek Zeus) 74 | (god Zeus) 75 | 76 | (rule (mortal ?x) (human ?x)) 77 | (rule (fallible ?x) (human ?x)) 78 | 79 | (rule (human ?x) 80 | (and (Greek ?x) (not (god ?x)))) 81 | 82 | (rule (address ?x Olympus) 83 | (and (greek ?x) (god ?x))) 84 | 85 | (rule (perfect ?x) 86 | (and (not (mortal ?x)) 87 | (not (fallible ?x)))) 88 | 89 | (and (address ?x ?y) 90 | (perfect ?x)) ;; => Mount Olympus (Zeus) 91 | 92 | (and (perfect ?x) 93 | (address ?x ?y)) ;; Nothing 94 | 95 | 96 | ;; But who is right? We can makes assumption of our 97 | ;; data here about that: Zeus is not mortal, Zeus 98 | ;; is not mortal, just because he is not human? 99 | ;; This is not sufficient information. 100 | 101 | ;; NOT here is NOT from the logic! 102 | ;; The NOT here is a filter of a closed world, 103 | ;; the complements of a assumption. 104 | ;; Logic makes assumptions of only two states. 105 | ;; This is a big problem. 106 | -------------------------------------------------------------------------------- /mit-6.001/3B-symbolic-differentiation.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | (defparameter *dx* 0.0001) 6 | 7 | (defun deriv-numerical (f) 8 | (lambda (x) 9 | (/ (- (funcall f (+ x *dx*)) 10 | (funcall f x)) 11 | *dx*))) 12 | 13 | ;; x^3 => 3x^2 14 | ;; 2^3 => 8 15 | ;; 3 * (2^2) => 12 16 | (funcall (deriv-numerical (lambda (x) (* x x x))) 2) ;; => 11.987 17 | 18 | (defun constant? (exp var) 19 | (and (atom exp) 20 | (not (eq exp var)))) 21 | 22 | (defun same-var? (exp var) 23 | (and (atom exp) 24 | (eq exp var))) 25 | 26 | (defun sum? (exp) 27 | (and (not (atom exp)) 28 | (eq (car exp) '+))) 29 | 30 | (defun power? (exp) 31 | (and (not (atom exp)) 32 | (eq (car exp) '^))) 33 | 34 | (defun make-sum (a1 a2) 35 | (list '+ a1 a2)) 36 | 37 | (defun make-product (m1 m2) 38 | (list '* m1 m2)) 39 | 40 | (defun power-rule (exp) 41 | (let ((base (cadr exp)) 42 | (pow (caddr exp))) 43 | (list '* pow `(^ ,base ,(1- pow))))) 44 | (deriv '(^ x 3) 'x) 45 | 46 | (setf (symbol-function 'a1) #'cadr) 47 | (setf (symbol-function 'a2) #'caddr) 48 | (setf (symbol-function 'm1) #'cadr) 49 | (setf (symbol-function 'm2) #'caddr) 50 | (setf (symbol-function '^) #'expt) ;; power symbol function 51 | 52 | (defun product? (exp) 53 | (and (not (atom exp)) 54 | (eq (car exp) '*))) 55 | 56 | (defun deriv (exp var) 57 | (cond ((constant? exp var) 0) 58 | ((same-var? exp var) 1) 59 | ((sum? exp) 60 | (make-sum (deriv (a1 exp) var) 61 | (deriv (a2 exp) var))) 62 | ((product? exp) 63 | (make-sum 64 | (make-product (m1 exp) 65 | (deriv (m2 exp) var)) 66 | (make-product (m2 exp) 67 | (deriv (m1 exp) var)))) 68 | ((power? exp) (power-rule exp)))) 69 | 70 | (defparameter foo '(+ (* a ( * x x)) 71 | (+ (* b x) c))) 72 | ;; second version of representation 73 | ;; simplifying algebraic expressions 74 | 75 | (defun make-sum (a1 a2) 76 | (cond ((and (numberp a1) 77 | (numberp a2)) 78 | (+ a1 a2)) 79 | ((and (numberp a1) (= a1 0)) 80 | a2) 81 | ((and (numberp a2) (= a2 0)) 82 | a1) 83 | (t (list '+ a1 a2)))) 84 | 85 | (defun make-product (m1 m2) 86 | (cond ((and (numberp m1) 87 | (numberp m2)) 88 | (+ m1 m2)) 89 | ((or (and (numberp m1) (= m1 0)) 90 | (and (numberp m2) (= m2 0))) 91 | 0) 92 | ((and (numberp m1) (= m1 1)) 93 | m2) 94 | ((and (numberp m2) (= m2 1)) 95 | m1) 96 | (t (list '* m1 m2)))) 97 | 98 | (deriv foo 'x) 99 | -------------------------------------------------------------------------------- /land-of-lisp/cap13-error-handling.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; :: Signaling a Condition 5 | 6 | ;; Throwing a error: 7 | (error "foo") 8 | ;; => The REPL is interrupted 9 | ;; *** - foo 10 | 11 | ;; Using the error command will interrupt your running Lisp program 12 | ;; unless you intercept the error elsewhere to prevent an interruption. 13 | 14 | ;; :: Creating Custom Conditions 15 | 16 | ;; A more sophisticated way to signal conditions is to first 17 | ;; define a custom condition using `define-condition`, as here: 18 | 19 | (define-condition foo () () 20 | (:report (lambda (condition stream) 21 | (princ "Stop FOOing around, numbskull!" stream)))) 22 | 23 | (error 'foo) 24 | 25 | ;; => The REPL is interrupted 26 | ;; *** - Stop FOOing around, numbskull! 27 | 28 | ;; As you can see, our custom message was printed. This technique allows 29 | ;; the programmer to get a more meaningful error report, customized for the 30 | ;; specific condition that was triggered. 31 | 32 | ;; :: Intercepting Conditions 33 | 34 | (defun bad-function () 35 | (error 'foo)) 36 | 37 | (handler-case (bad-function) 38 | (foo () "somebody signaled foo!") 39 | (bar () "somebody signaled bar!")) 40 | 41 | ;; => "somebody signaled foo!" 42 | ;; Our handler-case command intercepts the foo condition that was be 43 | ;; signaled through the bad-function call. This means that the program 44 | ;; can keep running without interruption, with the handler-case evaluating 45 | ;; as "somebody signaled foo!" 46 | 47 | ;; :: Protecting Resources Against Unexpected Conditions 48 | ;; We can ignore exceptions too, like the unsafe operations of Rust. 49 | ;; Is like say "This piece of code must run no matter what happens" 50 | ;; To the Lisp compiler 51 | 52 | (unwind-protect (/ 1 0) 53 | (princ "I need to say 'flubyduby' matter what")) 54 | 55 | ;; Actually the exception is signaled and a interruption is made, but, 56 | ;; the other statements will still be executed. 57 | 58 | ;; => DIVISION-BY-ZERO error 59 | ;; ... after abort 60 | ;; => I need to say 'flubyduby' matter what 61 | 62 | ;; Within the unwind-protect, we divide by 0, which signals a condition. But 63 | ;; even after we tell to compiler to abort, the program still prints its 64 | ;; crucial message 65 | 66 | ;; We can usually avoid calling unwind-protect directly by relying on Common 67 | ;; Lisp "with-" macros; many of these call unwind-protect themselves, under 68 | ;; the hood. 69 | 70 | ;; NOTE: In the comic book epilogue at the end of the book, you'll learn 71 | ;; about and additional feature of the Common Lisp signaling system called 72 | ;; `restarts`. 73 | 74 | ;; The continuation of this chapter is written on the "cap13-webserver.lisp" 75 | -------------------------------------------------------------------------------- /random/game-of-life-sdl.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela -- but i not have wrote that script 3 | 4 | (ql:quickload 'lispbuilder-sdl) 5 | (ql:quickload 'lispbuilder-sdl-gfx) 6 | (ql:quickload 'alexandria) 7 | 8 | (defparameter *world* (make-array '(100 100) :element-type 'bit)) 9 | 10 | ;; initialize 11 | (defun init-world! (world) 12 | (loop for i from 0 to (1- (array-dimension world 0)) do 13 | (loop for j from 0 to (1- (array-dimension world 1)) do 14 | (setf (aref world i j) (if (zerop (random 7)) 1 0))))) 15 | 16 | (defun count-neighboring-individual (i j world) 17 | (let ((next-i (if (= i (1- (array-dimension world 0))) 0 (1+ i))) 18 | (prev-i (if (= i 0) (1- (array-dimension world 0)) (1- i))) 19 | (next-j (if (= j (1- (array-dimension world 1))) 0 (1+ j))) 20 | (prev-j (if (= j 0) (1- (array-dimension world 1)) (1- j)))) 21 | (+ (aref world prev-i prev-j) 22 | (aref world prev-i j) 23 | (aref world prev-i next-j) 24 | (aref world i prev-j) 25 | (aref world i next-j) 26 | (aref world next-i prev-j) 27 | (aref world next-i j) 28 | (aref world next-i next-j)))) 29 | 30 | ;; return next generation world 31 | (defun update-next-generation (world) 32 | (let ((next-world (alexandria:copy-array world))) 33 | (loop for i from 0 to (1- (array-dimension world 0)) do 34 | (loop for j from 0 to (1- (array-dimension world 1)) do 35 | (cond ((and (zerop (aref world i j)) ; birth 36 | (= (count-neighboring-individual i j world) 3)) 37 | (setf (aref next-world i j) 1)) 38 | ((and (= (aref world i j) 1) ; die by under-population or overcrowding 39 | (or (<= (count-neighboring-individual i j world) 1) 40 | (>= (count-neighboring-individual i j world) 4))) 41 | (setf (aref next-world i j) 0))))) 42 | next-world)) 43 | 44 | (defun life () 45 | (sdl:with-init () 46 | (sdl:window 400 400) ; size of window 47 | (setf (sdl:frame-rate) 60) ; set frame-rate 60fps 48 | (init-world! *world*) 49 | (sdl:with-events () 50 | (:quit-event () t) 51 | (:idle () 52 | (setf *world* (update-next-generation *world*)) 53 | (loop for i from 0 to (1- (array-dimension *world* 0)) do 54 | (loop for j from 0 to (1- (array-dimension *world* 1)) do 55 | (if (= (aref *world* i j) 0) 56 | (sdl-gfx:draw-box (sdl:rectangle :x (* i 4) :y (* j 4) :w 4 :h 4) 57 | :color sdl:*black*) 58 | (sdl-gfx:draw-box (sdl:rectangle :x (* i 4) :y (* j 4) :w 4 :h 4) 59 | :color sdl:*white*)))) 60 | (sdl:update-display))))) 61 | 62 | (life) 63 | -------------------------------------------------------------------------------- /mit-6.001/2B-compund-data.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | ;; Here we used cons to construct pair of things 6 | ;; that structures are also called 'list structures' 7 | ;; after all, list are essentially recursively cons 8 | ;; (list 1 2 3) → (cons 1 (cons 2 (cons 3 nil))) 9 | 10 | 11 | #| Map of abstraction for: Rational Numbers 12 | 13 | Usage → Rational numbers → Pairs of nubmers 14 | ↓ ↓ ↓ 15 | +rat make-rat cons 16 | *rat numer car 17 | /rat denom cdr 18 | -rat inverse-rat gcd 19 | |# 20 | 21 | 22 | ;; i don't use gcd as name of that procedure 23 | ;; because clisp have a reserved name-space locked as macro for gcd 24 | ;; what are funny... because, why sucks gcd is a macro?! 25 | (defun my-gcd(a b) 26 | (if (= b 0) 27 | a 28 | (my-gcd b (mod a b)))) 29 | 30 | ;; rational numbers (re-implementations) 31 | (defun make-rat (n d) 32 | (let ((g (my-gcd n d))) 33 | (cons (/ n g) 34 | (/ d g)))) 35 | 36 | (defun numer (r) 37 | (car r)) 38 | 39 | (defun denom (r) 40 | (cdr r)) 41 | 42 | (defun inverse-rat (x) 43 | (make-rat (denom x) (numer x))) 44 | 45 | (defun +rat (x y) 46 | (make-rat (+ (* (numer x) (denom y)) 47 | (* (numer y) (denom y))) 48 | (* (denom x) (denom y)))) 49 | 50 | (defun -rat (x y) 51 | (+rat x (make-rat (- (numer y)) (denom y)))) 52 | 53 | (defun *rat (x y) 54 | (make-rat (* (numer x) (numer y)) 55 | (* (denom x) (denom y)))) 56 | 57 | (defun /rat (x y) 58 | (*rat x (inverse-rat y))) 59 | 60 | 61 | #| Map of abstraction fir: Segments and Vectors 62 | 63 | Segments → Vectors → Pairs of nubmers 64 | ↓ ↓ ↓ 65 | make-seg make-vector cons 66 | seg-start xcor car 67 | seg-end ycor cdr 68 | 69 | |# 70 | 71 | 72 | ;; vectors bi-dimensional 73 | ;; whose x y are numbers 74 | (defun make-vector (x y) (cons x y)) 75 | 76 | (defun xcor (v) (car v)) 77 | 78 | (defun ycor (v) (cdr v)) 79 | 80 | ;; whose p q are vectors 81 | (defun make-seg (p q) (cons p q)) 82 | 83 | (defun seg-start (s) (car s)) 84 | 85 | (defun seg-end (s) (cdr s)) 86 | 87 | (defun average (x y) 88 | (/ (+ x y) 2)) 89 | 90 | (defun midpoint (s) 91 | (let ((a (seg-start s)) 92 | (b (seg-end s))) 93 | (make-vector 94 | (average (xcor a) (xcor b)) 95 | (average (ycor b) (ycor b))))) 96 | 97 | (defun segment-length (s) 98 | (flet ((square (x) (* x x))) 99 | (let ((dx (- (xcor (seg-end s)) 100 | (xcor (seg-start s)))) 101 | (dy (- (ycor (seg-end s)) 102 | (ycor (seg-start s))))) 103 | (sqrt (+ (square dx) 104 | (square dy)))))) 105 | 106 | 107 | 108 | ;; but all are defined by cons, car cdr... primitive procedures?? 109 | ;; So... I say: "Hey, is primitive! Is magic". NO!! 110 | ;; We can build that procedures that way: 111 | 112 | 113 | (defun crazy-cons (a b) 114 | (lambda (pick) 115 | (cond ((= pick 1) a) 116 | ((= pick 2) b)))) 117 | 118 | (defun crazy-car (λ) (funcall λ 1)) 119 | 120 | (defun crazy-cdr (λ) (funcall λ 2)) -------------------------------------------------------------------------------- /mit-6.001/9A-register-machines.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; The Hardware Machine Description in Lisp 5 | 6 | ;; a simple macro to that file compiles. 7 | (defmacro define-machine (machine &rest body) 8 | `(defparameter ,machine (quote ,body))) 9 | 10 | (defun gcd. (a b) 11 | (if (= b 0) 12 | A 13 | (gcd. b (mod a b)))) 14 | 15 | ;; A machine description for the GCD procedure/machine 16 | (define-machine gcd-machine 17 | (registers a b t) 18 | (controller 19 | main (assign a (read)) 20 | (assign b (read)) 21 | loop (branch (zerop (fetch b)) 22 | done) 23 | (assign t (mod (fetch a) (fetch b))) 24 | (assign a (fetch b)) 25 | (assign b (fetch t)) 26 | (goto loop) 27 | done (perform (print (fetch a))) 28 | (goto main))) 29 | 30 | 31 | (defun fact (n) 32 | (if (= n 1) 33 | 1 34 | (* n (fact (1- n))))) 35 | 36 | 37 | (fact 10000) 38 | 39 | ;; fact is a problem, because before build this machine, we need fact exists 40 | ;; and remember the last operations to reduce the overall expression 41 | ;; only in the end => n! = n*(n -1)...1 42 | ;; for that, will put each `n` on stack before the recursive call 43 | 44 | 45 | (define-machine fact-machine 46 | (registers n) 47 | (assign continue done) 48 | (controller 49 | loop (branch (= 1 (fetch n)) base) 50 | (save continue) 51 | (save n) 52 | (assign n (-1 (fetch n))) 53 | (assign continue aft) 54 | (goto loop) 55 | aft (restore n) 56 | (restore continue) 57 | (assign val (* (fetch n) (fetch val))) 58 | (goto (fetch continue)) 59 | base (assign val (fetch n)) 60 | (goto (fetch continue)) 61 | done)) 62 | 63 | 64 | 65 | (defun fib (n) 66 | (if (< n 2) 67 | n 68 | (+ (fib (- n 1)) 69 | (fib (- n 2))))) 70 | 71 | ;; this is not lisp code, ok? 72 | ;; is a embed language for machine code made in lisp 73 | ;; to be interpreted in lisp, but is not lisp!!!!!!!! 74 | (define-machine fib-machine 75 | (registers n) 76 | (controller 77 | (assign continue fib-done) 78 | fib-loop ; n contains arg, continue as recipient 79 | (branch (< (fetch n) 2) immediate-ans) 80 | (save continue) 81 | (assign continue after-fibs-n-1) 82 | (save n) 83 | (assign n (- (fetch n) 1)) 84 | (goto fib-loop) 85 | after-fib-n-1 ; after get the first fib 86 | (restore n) 87 | (restore continue) ; useless? 88 | (assign n (- (fetch n) 2)) 89 | (save continue) ; useless? 90 | (assign continue after-fib-n-2) 91 | (save val) 92 | (goto fib-loop) 93 | after-fib-n-2 94 | (assign n (fetch val)) ;; fib(n - 2) 95 | (restore val) 96 | (restore continue) 97 | (assign val 98 | (+ (fetch val) 99 | (fetch n))) ;; fib(n -1) + fib(n - 2) 100 | (goto fetch continue) 101 | immediate-ans 102 | (assign val (fetch n)) 103 | (goto (fetch continue)) 104 | fib-done)) 105 | 106 | 107 | ;; Machine primitives: DATAPATH + CONTROLLER + MEMORY 108 | 109 | 110 | ;; actually, this really seems a low-level description for 111 | ;; a machine, Lisp Assembly? HAHA... But I don't get the whole 112 | ;; picture of this lecture. Maybe I need rewatch this in someday 113 | -------------------------------------------------------------------------------- /mit-6.001/8A-logic-programming-I.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | #| 5 | Some explorations on Logic Programming and Declarative Programming 6 | 7 | This lecture don't cover the implementation of the query system based on logic! 8 | |# 9 | 10 | ;; (+merge '(4 5 6) '(1 2 3)) => '(1 2 3 4 5 6) 11 | (defun +merge (x y) 12 | (cond ((null x) y) 13 | ((null y) x) 14 | (t (let ((a (car x)) 15 | (b (car y))) 16 | (if (< a b) 17 | (cons a 18 | (+merge (cdr x) y)) 19 | (cons b 20 | (+merge x (cdr y)))))))) 21 | 22 | ;; in logic 23 | 24 | #| 25 | (1 3 7) and (2 4 1) merge-to-form ? 26 | (1 3 7) and ? merge-to-form (1 2 3 4 7 8) 27 | x? and y? merge-to-form (1 2 3 4 7 8) 28 | 29 | Declarative properties, logical thinking. 30 | 31 | The usage of Logic Programming (e.g.:: Prolog) is three: 32 | 33 | 1. To express what is true 34 | 2. Check whether something is true 35 | 3. Find what's is true 36 | 37 | |# 38 | 39 | ;; this macros don't exists on lectures, i put here just for fun and to the file compiles. 40 | 41 | (defvar jobs nil) 42 | (defvar salaries nil) 43 | (defvar supervisors nil) 44 | (defvar addresses nil) 45 | 46 | (defmacro job (who job) 47 | `(push (cons (quote ,who) (quote ,job)) jobs)) 48 | 49 | (defmacro salary (who salary) 50 | `(push (cons (quote ,who) (quote ,salary)) salaries)) 51 | 52 | (defmacro supervisor (who s) 53 | `(push (cons (quote ,who) (quote ,s)) supervisors)) 54 | 55 | (defmacro address (who a) 56 | `(push (cons (quote ,who) (quote ,a)) addresses)) 57 | 58 | 59 | ;; entry 1 60 | (job (Bitdiddle Ben) (computer wizard)) 61 | 62 | (salary (Bitdiddle Ben) 40000) 63 | 64 | (supervisor (Bitdiddle Ben) 65 | (Warbucks Oliver)) 66 | 67 | (address (Bitdiddle Ben) 68 | (Slunerville (Ridge Road) 10)) 69 | 70 | ;; entry 2 71 | (job (Hacker Alyssa P) 72 | (computer programmer)) 73 | 74 | (salary (Hacker Alyssa P) 35000) 75 | 76 | (supervisor (Hacker Alyssa P) 77 | (Bitdiddle Ben)) 78 | 79 | (address (Hacker Alyssa P) 80 | (Cambridge (Mass Ave) 78)) 81 | 82 | ;; entry 3 83 | (job (Tweakit Lan E) 84 | (computer technician)) 85 | 86 | 87 | (salary (Tweakit Len E) 15000) 88 | 89 | (supervisor (Tweakit Len E) 90 | (Bitdiddle Ben)) 91 | 92 | (address (Tweakit Len E) 93 | (Boston (Bay State Road) 22)) 94 | 95 | ;; entry 4 96 | 97 | (job (Reasoner Louis) 98 | (computer programmer trainee)) 99 | 100 | (salary (Reasoner Louis) 20000) 101 | 102 | (supervisor (Reasoner Louis) 103 | (Hacker Alyssa P)) 104 | 105 | (address (Reasoner Louis) 106 | (Slunerville (Pine Tree Road) 107 | 80)) 108 | 109 | 110 | ;; primitives => 111 | ;; * query 112 | ;; ~ like the data entry above 113 | 114 | ;; means of combination => 115 | ;; * and 116 | ;; * not 117 | ;; * or 118 | ;; * lisp-value 119 | 120 | ;; (and (job ?x (computer . ?y)) 121 | ;; (not (and (supervisor ?x ?z) 122 | ;; (job ?z (computer . ?w)))) 123 | 124 | ;; means of abstraction => 125 | ;; * rules 126 | 127 | ;; (rule (bigshot ?x ?dept) ;; conclusion 128 | ;; (and (job ?x (?dept . ?y)) ;; body 129 | ;; (not (and (supervisor ?x ?z) 130 | ;; (job ?z (?dept . ?w)))))) 131 | 132 | ;; backing to the merge problem 133 | 134 | ;; (rule (merge-to-form () ?y ?y)) 135 | ;; (rule (merge-to-form ?y () ?y)) 136 | 137 | #| 138 | 139 | (rule 140 | (merge-to-form (?a . ?x) (?b . ?y) (?b . ?z)) 141 | (and (merge-to-form (?a . ?x) ?y ?z) 142 | (lisp-value > ?a ?b))) 143 | 144 | |# 145 | -------------------------------------------------------------------------------- /mit-6.001/10B-storage-allocation-and-garbage-collector.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | ;; Storage Allocation and Garbage Collector 6 | ;; Representing Memory List Structure 7 | 8 | ;; ... again register machines. This is a lot of mess. 9 | 10 | ;; Godel says that any system information can be represented by numbers in that way: 11 | ;; (cons x y) => 2^x * 3^y, so (cons 1 1) => 2 * 3 = 6 12 | 13 | (defmacro define-assembly (name &rest instructions) 14 | `(defparameter ,name (quote ,instructions))) 15 | 16 | 17 | (define-assembly freelist-allocation 18 | (assign a (cons (fetch b) 19 | (fetch c))) 20 | (assign a (fetch free)) 21 | (assign free (vector-ref (fetch the-cdrs) 22 | (fetch free))) 23 | (perform (vector-set! (fetch the-cars) 24 | (fetch a) 25 | (fetch b))) 26 | (perform (vector-set! (fetch the-cdrs) 27 | (fetch a) 28 | (fetch c)))) 29 | 30 | 31 | ;; garbage collector 32 | (define-assembly gc-code 33 | gc 34 | (assign thing (fetch root)) 35 | (assign continue) 36 | mark 37 | (branch (not-pair? (fetch thing)) 38 | done) 39 | pair 40 | (assign mark-flag 41 | (vector-ref (fetch the-marks) 42 | (fetch thing))) 43 | (branch (= (fetch mark-flag) 1) 44 | done) 45 | (perform (vector-set! (fetch the-marks) 46 | (fetch thing))) 47 | mcar 48 | (push thing) 49 | (push continue) 50 | (assign continue mcdr) 51 | (assign thing (vector-ref (fetch the-cars) 52 | (fetch thing))) 53 | (goto mark) 54 | mcdr 55 | (pop continue) 56 | (pop thing) 57 | (assign thing 58 | (vector-ref (fetch the-cdrs) 59 | (fetch thing))) 60 | (goto mark) 61 | done 62 | (goto (fetch continue))) 63 | 64 | (define-assembly auxiliary-gc 65 | (assign free '()) 66 | (assign scan (1- (fetch memtop))) 67 | slp 68 | (branch (negative? (fetch scan)) 69 | end) 70 | (assign mark-flag 71 | (vector-ref (fetch the-marks) 72 | (fetch scan))) 73 | (branch (= (fetch mark-flag) 74 | 1) 75 | unmk) 76 | (perform (vector-set! (fetch the-cdrs) 77 | (fetch scan) 78 | (fetch free))) 79 | (assign free (fetch scan)) 80 | (assign scan (1- (fetch scan))) 81 | (goto slp) 82 | unmk 83 | (perform (vector-set! (fetch the-marks) 84 | (fetch scan) 85 | 0)) 86 | (assign scan (1- (fetch scan))) 87 | (goto slp) 88 | end) 89 | 90 | ;; cited fastest garbage collector algorithm: 91 | ;; Minsky-Feinchel-Yochelson Garbage Collector Algorithm, 61' 92 | 93 | ;; The lecture finishes introducing the halting problem 94 | ;; and problems not computables. 95 | 96 | (defun inf () 97 | (lambda () (funcall (lambda (x) (funcall x x)) 98 | (lambda (x) (funcall x x))))) 99 | 100 | (defun diag1 (p) 101 | (if (safe? p p) 102 | (inf) 103 | 3)) 104 | 105 | (diag1 diag1) ;; safe? 106 | 107 | ;; diag here comes to the Diagonal Argument of Cantor 108 | ;; proving real numbers are not countable by showing 109 | ;; that the numbers between a segment line is bigger than 110 | ;; all set of natural numbers -- Sussman explanation 111 | (defun diag2 (p) 112 | (if (safe? p p) 113 | (other-than (p p)) 114 | 'false)) 115 | 116 | 117 | (defun other-than (p) 118 | (if (eq p 'x) 119 | 'x 120 | p)) 121 | 122 | ;; IS NOT POSSIBLE TO TELL IF A FUNCTION WILL GET A INFINITE LOOP 123 | ;; UNTIL YOU RUN IT. 124 | -------------------------------------------------------------------------------- /mit-6.001/4B-generic-operators.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; Arithmetic operations on 5 | ;; complex numbers 6 | 7 | 8 | ;; ** COMPLEX NUMBERS PROPERTIES ** 9 | ;; Re(Z1 + Z2) = Re(Z1) + Re(Z2) 10 | ;; Im(Z1 + Z2) = Im(Z1) + Im(Z2) 11 | ;; Mag(Z1 * Z2) = Mag(Z1) * Mag(Z2) 12 | ;; Angle(Z1 * Z2) = Angle(Z1) + Angle(Z2) 13 | 14 | ;; ** SELECTORS ** 15 | ;; REAL-PART -> Z 16 | ;; IMG-PART -> Z 17 | ;; MAGNITUDE -> Z 18 | ;; ANGLE -> Z 19 | 20 | ;; ** CONSTRUCTORS ** 21 | ;; MAKE-RECTANGULAR -> X -> Y 22 | ;; MAKE-POLAR -> R -> A 23 | 24 | ;; SOLUTION FOR MULTIPLE REPRESENTATIONS 25 | ;; TYPED DATA + GENERIC OPERATORS 26 | 27 | ;; constructor 28 | (defun attach-type (type contents) 29 | (cons type contents)) 30 | 31 | ;; selectors 32 | (defun complex-type (datum) 33 | (car datum)) 34 | 35 | (defun contents (datum) 36 | (cdr datum)) 37 | 38 | ;; type predicates 39 | 40 | (defun rectangular? (z) 41 | (eq (complex-type z) 'rectangular)) 42 | 43 | (defun polar? (z) 44 | (eq (complex-type z) 'polar)) 45 | 46 | ;; GEORGE IMPLEMENTATION 47 | ;; Representing complex numbers as 48 | ;; pairs REAL-PART, IMAGINARY-PART 49 | 50 | (defun make-rectangular (x y) 51 | (attach-type 'rectangular (cons x y))) 52 | 53 | (defun real-part-rectangular (z) 54 | (car z)) 55 | 56 | (defun imag-part-rectangular (z) 57 | (cdr z)) 58 | 59 | (defun magnitude-rectangular (z) 60 | (sqrt (+ (square (car z)) 61 | (square (cdr z))))) 62 | 63 | (defun angle-rectangular (z) 64 | (atan (/ (cdr z) (car z)))) 65 | 66 | ;; MARTHA IMPLEMENTATION 67 | ;; Representing complex numbers as 68 | ;; pairs MAGNITUDE, ANGLE 69 | 70 | 71 | (defun make-polar (r a) 72 | (attach-type 'polar (cons r a))) 73 | 74 | (defun magnitude-polar (z) 75 | (car z)) 76 | 77 | (defun angle-polar (z) 78 | (cdr z)) 79 | 80 | (defun real-part-polar (z) 81 | (* (car z) (cos (cdr z)))) 82 | 83 | (defun imag-part-polar (z) 84 | (* (car z) (sin (cdr z)))) 85 | 86 | ;; GENERIC SELECTORS FOR COMPLEX NUMBERS 87 | 88 | 89 | (defun real-part (z) 90 | (cond ((rectangular? z) 91 | (real-part-rectangular 92 | (contents z))) 93 | ((polar? z) 94 | (real-part-polar 95 | (contents z))))) 96 | 97 | (defun imag-part (z) 98 | (cond ((rectangular? z) 99 | (imag-part-rectangular 100 | (contents z))) 101 | ((polar? z) 102 | (imag-part-polar))) 103 | (contents z)) 104 | 105 | (defun magnitude (z) 106 | (cond ((rectangular? z) 107 | (magnitude-rectangular 108 | (contents z))) 109 | ((polar? z) 110 | (magnitude-polar 111 | (contents z))))) 112 | 113 | (defun angle (z) 114 | (cond ((rectangular? z) 115 | (angle-rectangular 116 | (contents z))) 117 | ((polar? z) 118 | (angle-polar 119 | (contents z))))) 120 | 121 | (defun +c (z1 z2) 122 | (make-rectangular 123 | (+ (real-part z1) (real-part z2)) 124 | (+ (imag-part z1) (imag-part z2)))) 125 | 126 | (defun -c (z1 z2) 127 | (make-rectangular 128 | (- (real-part z1) (real-part z2)) 129 | (- (imag-part z1) (imag-part z2)))) 130 | 131 | (defun *c (z1 z2) 132 | (make-polar 133 | (* (magnitude z1) (magnitude z2)) 134 | (+ (angle z1) (angle z2)))) 135 | 136 | (defun /c (z1 z2) 137 | (make-polar 138 | (/ (magnitude z1) (magnitude z2)) 139 | (- (angle z1) (angle z2)))) 140 | 141 | ;; an alternative way to represent this, avoid the MANAGER is using a table 142 | ;; for relate each type and the correct procedure. In the lecture is build on top using this technique for rational, polynomial, complex and ordinary numbers the generic operators add, sub, mul and div. 143 | -------------------------------------------------------------------------------- /mit-6.001/10A-compilation.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | #| 6 | Compilation 7 | 8 | The first strategy for compilation is the zeroth order compilation. That claims in these simple procedures: 9 | 10 | - interpret the code for register machine 11 | - instead execute that, save. 12 | 13 | Done. No optimizations here. 14 | But interpreter is dumb, it is very pessimistic because anything can happens. 15 | By other hand, compilers know what is necessary or no (well, it can know). 16 | 17 | A lot of stack is used during interpretation, but sometimes is useless. 18 | 19 | More details of this lecture is on the Chapter 5 of Structure Interpretation of Computer Programs Book Ed2. 20 | |# 21 | 22 | (defmacro define-compilation (name &rest code) 23 | `(defparameter ,name (quote ,code))) 24 | 25 | ;; a general view of a compilation of (op a b) 26 | (define-compilation op-a-b 27 | (preserves env) 28 | (compile op) 29 | (result in fun) 30 | (preserves fun) 31 | (preserves env) 32 | (compile a) 33 | (assign argl (cons (fetch val) nil)) 34 | (result in val) 35 | (preservs argl) 36 | (compile b) 37 | (result in val) 38 | (assign argl (cons (fetch val) (fetch argl))) 39 | (goto apply-dispatch)) 40 | 41 | ;; treating assignments and using the stack 42 | ;; to preserve registers 43 | 44 | ;; ===:: APPENDING SEQUENCE OF CODES ::== 45 | ;; append seq1 and seq2 preserving reg 46 | 47 | ;; if seq2 needs reg 48 | ;; and seq1 modifies reg 49 | ;;; :: CODE 50 | ;; (save reg) 51 | ;; 52 | ;; (restore reg) 53 | ;; 54 | ;; OTHERWISE 55 | ;;; :: CODE 56 | ;; 57 | ;; 58 | 59 | 60 | ;; sequences of instructions need be tagged about 61 | ;; the registers will be modified 62 | ;; and the registers needed 63 | 64 | ;; this is the general notation of code tagging about 65 | ;; registers modified and needed 66 | (define-compilation template-for-tagging 67 | < sequence of instrunctions > 68 | < set of registers modified > 69 | < set of regs needed >) 70 | 71 | ;; lets compile a factorial function recursive 72 | 73 | (defun fact (n) 74 | (cond ((= n 0) 1) 75 | (t (* n (fact (1- n)))))) 76 | 77 | 78 | (define-compilation fact-compiled 79 | entry1 ;; label 80 | (assign env (compiled-procedure-env (fetch fun))) 81 | (assign env (extended-binding-env '(n) 82 | (fetch argl) 83 | (fetch env))) 84 | (save env) ;; preserving env, will modify in sequence 85 | (assign fun (lookup-variable-value '* (fetch env))) 86 | (assign val (lookup-variable-value 'n (fetch env))) 87 | (assign argl (cons (fetch val) '())) 88 | (assign val '0) 89 | (assign argl (cons (fetch val) (fetch argl))) ;; append argl 90 | (assign continue after-call3) 91 | (goto apply-dispatch) 92 | 93 | after-call3 ;; label 94 | (restore env) 95 | (branch (true? (fetch val)) true-branch2) 96 | (assign fun (lookup-variable-value '* (fetch env))) 97 | (save fun) 98 | (assign val (lookup-variable-value 'm (fetch env))) 99 | (assign argl (cons (fetch val) '())) 100 | (save argl) 101 | (assign fun (lookup-variable-value 'fact (fetch env))) 102 | (save fun) 103 | (assign fun (lookup-variable-value '- (fetch env))) 104 | (assign val (lookup-variable-value 'n (fetch env))) 105 | (assign argl (cons (fetch val)) '()) 106 | (assign val '1) 107 | (assign argl (cons (fetch val (fetch argl)))) 108 | (assign continue after-call5) 109 | (save continue) 110 | (goto apply-dispatch) 111 | 112 | after-call5 ;; label 113 | (assign argl (cons (fetch val) '())) 114 | (restore fun) 115 | (assign continue after-call4) 116 | (save continue) 117 | (goto apply-dispatch) 118 | 119 | after-call4 ;; label 120 | (restore argl) 121 | (assign argl (cons (fetch val) (fetch argl))) 122 | (restore fun) 123 | (goto apply-dispatch) 124 | 125 | true-branch2 126 | (assign val '1) 127 | (restore continue) 128 | (goto (fetch continue))) 129 | -------------------------------------------------------------------------------- /mit-6.001/3A-data-abstraction.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; 2D Vector Abstraction 5 | 6 | (setf (symbol-function 'make-vector) #'cons) 7 | (setf (symbol-function 'xcor) #'car) 8 | (setf (symbol-function 'ycor) #'cdr) 9 | 10 | (defun +vect (u v) 11 | (make-vector (+ (xcor u) 12 | (xcor v)) 13 | (+ (ycor u) 14 | (ycor v)))) 15 | 16 | (defun scale (s v) 17 | (make-vector (* s (xcor v)) 18 | (* s (ycor v)))) 19 | 20 | 21 | ;; Segment on Plane Abstraction 22 | 23 | (setf (symbol-function 'make-seg) #'cons) 24 | (setf (symbol-function 'seg-start) #'car) 25 | (setf (symbol-function 'seg-end) #'cdr) 26 | 27 | (defun segment-length (segment) 28 | (let* ((x (- (xcor (seg-start segment)) 29 | (xcor (seg-end segment)))) 30 | (y (- (ycor (seg-start segment)) 31 | (ycor (seg-end segment))))) 32 | (sqrt (+ (* x x) 33 | (* y y))))) 34 | 35 | ;; Data can be grouped using cons and a 36 | ;; general construction is a List 37 | 38 | ;; List construction 39 | (cons 1 (cons 2 (cons 3 nil))) ;; => (1 2 3) 40 | (list 1 2 3) ;; => 1 2 3 41 | 42 | ;; And accessed using car and cdr 43 | 44 | (defparameter 1-to-4 (list 1 2 3 4)) 45 | (car 1-to-4) ;; 1 46 | (cdr 1-to-4) ;; (2 3 4) 47 | (car (cdr 1-to-4)) ;; (2) 48 | 49 | ;; Recursive data is useful for recursive procedures 50 | ;; We will implement a naive implementation of function map and for-each 51 | 52 | (defun naive-map (p l) 53 | "Apply the p procedure at each element of list l 54 | and return a list" 55 | (if (null l) 56 | nil 57 | (cons (funcall p (car l)) 58 | (naive-map p (cdr l))))) 59 | 60 | (naive-map #'1+ 1-to-4) 61 | (mapcar (lambda (x) (+ x 1)) 1-to-4 ) ;; default implementation 62 | 63 | (defun for-each (p l) 64 | "Apply the p procedure at each element of list and 65 | return *done*" 66 | (if (null l) 67 | '*done* 68 | (progn (funcall p (car l)) 69 | (for-each p (cdr l))))) 70 | 71 | (for-each #'print 1-to-4) 72 | 73 | ;; Second Part: Peter's Language (DSL) about images 74 | 75 | ;; primitive: picture 76 | 77 | ;; rectangle 78 | ;; (make-rect) 79 | ;; (horiz) 80 | ;; (vert) 81 | ;; (origin) 82 | 83 | (defun make-rect (origin horiz vert) 84 | (cons origin (cons horiz vert))) 85 | 86 | (setf (symbol-function 'origin) #'car) 87 | (setf (symbol-function 'horiz) #'cadr) 88 | (setf (symbol-function 'vert) #'cddr) 89 | 90 | (defun coord-map (rect) 91 | (lambda (point) 92 | (+vect (+vect (scale (xcor point) 93 | (horiz rect)) 94 | (scale (ycor point) 95 | (vert rect))) 96 | (origin rect)))) 97 | 98 | (defun make-picture (seglist) 99 | (lambda (rect) 100 | (for-each 101 | (lambda (s) 102 | (drawline 103 | ((coord-map rect) (seg-start s)) 104 | ((coord-map rect) (seg-end s)))) 105 | seglist))) 106 | 107 | (defun beside (p1 p2 a) 108 | (lambda (rect) 109 | (funcall p1 (make-rect 110 | (origin rect) 111 | (scale a (horiz rect)) 112 | (vert rect))) 113 | (funcall p2 (make-rect 114 | (+vect (origin rect) 115 | (scale a (horiz rect))) 116 | (scale (- 1 a) (horiz rect)) 117 | (vert rect))))) 118 | 119 | 120 | (defun rotate90 (pict) 121 | (lambda (rect) 122 | (funcall pict (make-rect (+vect (origin rect) 123 | (horiz rect)) 124 | (vert rect) 125 | (scale -1 (horiz rect)))))) 126 | 127 | (defun right-push (p n a) 128 | (if (= n 0) 129 | p 130 | (beside p (right-push p (1- n) a) a))) 131 | 132 | 133 | ;; this is a example how can be powerful writing a domain-specific-language 134 | ;; instead breaking your big task and a tree of tasks. 135 | -------------------------------------------------------------------------------- /mit-6.001/7A-metacircular-evaluator-I.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | #| 5 | 6 | -- * A META-CIRCULAR COMPILER OF MINIMAL LISP * -- 7 | 8 | Every function symbol with prefixed '+ is used to not conflict with the namespace of reserved special forms 9 | of the current Lisp compiler. 10 | |# 11 | 12 | ;; assumes lambda exp => (closure ((vars) body) env) 13 | 14 | (defun primitive? (_) 15 | (or _ t)) 16 | 17 | (defun apply-primeop (proc args) 18 | (+apply proc args)) 19 | 20 | 21 | (defun pair-up (vars vals) 22 | (loop for x in vars 23 | for y in vals 24 | collect (cons x y))) 25 | 26 | (defun assq (sym alist) 27 | (cond ((eq alist '()) nil) 28 | ((eq sym (caar alist)) 29 | (car alist)) 30 | (t (assq sym (cdr alist))))) 31 | 32 | (defun lookup (sym env) 33 | (cond ((eq env '()) (error 'UBV)) ;; UNBOUND VARIABLE 34 | (t (funcall (lambda (vcell) 35 | (cond ((eq vcell '()) 36 | (lookup sym (cdr env))) 37 | (t (cdr vcell)))) 38 | (assq sym (car env)))))) 39 | 40 | (defun bind (vars vals env) 41 | (cons (pair-up vars vals) env)) 42 | 43 | (defun +eval (exp env) 44 | (cond ((numberp exp) exp) 45 | ((symbolp exp) (lookup exp env)) 46 | ((eq (car exp) 'quote) (cadr exp)) 47 | ((eq (car exp) 'lambda) 48 | (list 'closure (cdr exp) env)) 49 | ((eq (car exp) 'cond) 50 | (evcond (cdr exp) env)) 51 | (t (+apply (+eval (car exp) env) 52 | (+eval (cdr exp) env))))) 53 | 54 | 55 | (defun +apply (proc args) 56 | (cond ((primitive? proc) 57 | (apply-primeop proc args)) 58 | ((eq (car proc) 'closure) 59 | (+eval (cadadr proc) 60 | (bind (caadr proc) 61 | args 62 | (caddr proc)))) 63 | (t 'error))) 64 | 65 | (defun false? (x) 66 | (eq x nil)) 67 | 68 | (defun evlist (l env) 69 | (cond ((eq l '()) '()) 70 | (t (cons 71 | (+eval (car l) env) 72 | (evlist (cdr l) env))))) 73 | 74 | (defun evcond (clauses env) 75 | (cond ((eq clauses '()) '()) 76 | ((eq (caar clauses) t) 77 | (+eval (cadar clauses) env)) 78 | ((false? (+eval (caar clauses) env)) 79 | (evcond (cdr clauses) env)) 80 | (t (+eval (cadar clauses) env)))) 81 | 82 | 83 | #| Evaluating expression with this compiler using substitution model 84 | 85 | => (eval '(((lambda (x) (lambda (y) (+ x y))) 3) 4) ) 86 | => (apply (eval '((lambda (x) (lambda (y) (+x y))) 3) ) 87 | (evlist '(4) )) 88 | => (apply (eval '((lambda (x) (lambda (y) (+ x y))) 3) ) 89 | (cons (eval '4 ))) 91 | => (apply (eval '((lambda (x) (lambda (y) (+ x y))) 3) ) 92 | (cons 4 '())) 93 | => (apply (eval '((lambda (x) (lambda (y) (+ x y))) 3) ) 94 | '(4)) 95 | => (apply (apply (eval '(lambda (x) (lambda (+ x y))) ) 96 | '(3)) 97 | '(4)) 98 | 99 | => (apply (apply '(closure ((x) (lambda (y) (+ x y))) ) 100 | '(3)) 101 | '(4)) 102 | => (apply (eval '(lambda (y) (+ x y)) ) 103 | '(4)) 104 | => (apply '(closure ((y) (+ x y)) ) 105 | '(4)) 106 | => (eval (+ x y) ) 107 | => (apply (eval '+ ) 108 | (evlist '(x y) )) 109 | => (apply '+ '(3 4)) 110 | 7 111 | 112 | The eval/apply dancing. 113 | 114 | EVAL → PROC, ARGS → APPLY 115 | ↓ ↓ 116 | ====> EXP, ENV <====== 117 | 118 | 119 | |# 120 | 121 | 122 | ;; fixed points :: (Y F) = (Y (Y F)) 123 | 124 | 125 | (defun Y (f) 126 | (funcall (lambda (x) (funcall f x x)) 127 | (lambda (x) (funcall f x x)))) 128 | 129 | ;; (y #'print) bug!, y combinators! 130 | 131 | #| 132 | Y = (lambda (f) 133 | ((lambda (x) (f (x x))) 134 | (lambda (x) (f (x x))))) 135 | 136 | (Y F) = ((lambda (x) (F (x x))) 137 | (lambda (x) (F (x x)))) 138 | = (F ((lambda (x) (F (x x))) 139 | (lambda (x) (F (x x))))) 140 | (Y F) = (F (Y F)) 141 | 142 | |# 143 | -------------------------------------------------------------------------------- /land-of-lisp/cap14-functional-programming.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | #| 6 | -- Functional Programming 7 | 8 | In this chapter, you're going to learn about the first advanced 9 | Lisp concept, called the functional programming technique. 10 | 11 | Here are some important properties of mathematical functions that 12 | we'll want our Lisp functions to obey as well: 13 | 14 | + The function always returns the same result, as long as the same 15 | argument are passed into it. (This is often referred to as referential 16 | transparency) 17 | + The function never references variables that are defined outside the 18 | function, unless we are certain that these variables will remain 19 | constant 20 | + No variables are modified (or mutated, as functional programmers like 21 | to say) by the function. 22 | + The purpose of the function is to do nothing other than to return a 23 | result 24 | + The function doesn't do anything that is visible to the outside world, 25 | such as pop up a dialog box on the screen or make your computer go 26 | "Bing!" 27 | + The function doesn't take information from an outside source, such as 28 | the keyboard or the hard drive. 29 | 30 | |# 31 | 32 | 33 | ;; a great example of true mathematical function is the sine function 34 | 35 | (sin 0.5) 36 | ;; => 0.47942555 37 | 38 | 39 | ;; Whenever a piece of code does something that is visible to the outside 40 | ;; world, such as go "Bing!" or display a dialog box on the screen, 41 | ;; we say that the code causes a side effect. 42 | ;; Functional programmers think of such side effects as making your code 43 | ;; "dirty" 44 | 45 | 46 | ;; Let's give an example of a functional style program: 47 | 48 | ;; the clean, functional part 49 | (defun add-widget (database widget) 50 | (cons widget database)) 51 | 52 | ;; the dirty, non-functional part 53 | (defparameter *database* nil) 54 | (defun main-loop () 55 | (loop (princ "Please enter the name of a new widget: ") 56 | (setf *database* (add-widget *database* (read))) 57 | (format t "The database contains the following: ~{~a~^, ~}~%" *database*))) 58 | 59 | 60 | ;; NOTE: Some programming languages are even more focused on fp than Lisp is. 61 | ;; Haskell, for instance, has powerful features that let you write 99.9% of 62 | ;; your code in a functional style. In the end, however, your program will still 63 | ;; need to have some kind of side effect; otherwise, your code couldn't 64 | ;; accomplish anything useful. 65 | 66 | 67 | ;; :: Higher-Order Programming 68 | ;; The most powerful tool for code composition when writing functional 69 | ;; code is higher-order programming which lets you use functions that 70 | ;; accept other function as parameters. 71 | 72 | ;; Comparison between imperative style and functional style 73 | 74 | ;; -> imperative mode, add 2 to each element 75 | (defparameter *my-list* '(4 7 2 3) "a useless list") 76 | (loop for n below (length *my-list*) 77 | do (setf (nth n *my-list*) (+ (nth n *my-list*) 2))) 78 | ;; => NIL 79 | *my-list* ;; => (6 9 4 5) 80 | 81 | ;; + memory efficient (don't allocated new data) 82 | ;; + time efficient 83 | ;; - destroy data 84 | 85 | ;;; -> Using the functional style 86 | (defun add-two (list) 87 | (when list 88 | (cons (+ 2 (car list)) 89 | (add-two (cdr list))))) 90 | 91 | (add-two '(4 7 2 3)) 92 | ;; => '(6 9 4 5) 93 | 94 | ;; - memory inefficient (create new data) 95 | ;; + time efficient 96 | ;; + don't destroy data 97 | 98 | ;; Using Higher-Order functions 99 | (mapcar (lambda (x) 100 | (+ x 2)) 101 | '(4 7 2 3)) 102 | ;; => '(6 9 4 5) 103 | 104 | ;; Benefits of Functional Programming: 105 | ;; + Functional programming reduces bugs 106 | ;; + Functional programs are more compact 107 | ;; + Functional code is more elegant 108 | 109 | ;; Problems of Functional Programming: 110 | ;; - In general is inefficient¹ 111 | 112 | 113 | ;; ¹: for that, fp programmers, created techniques like: 114 | ;; Memoization, Tail Call Optimization, Higher-Order Programming 115 | ;; and another things. 116 | ;; Using good techniques a functional program can reach the same 117 | ;; performance of any other style. 118 | -------------------------------------------------------------------------------- /land-of-lisp/cap18-lazy-programming.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; LAZY PROGRAMMING 5 | 6 | ;; PROG: Creating the Lazy and Force Commands 7 | ;; NOTE: This chapter has a lazy evaluation system very similar 8 | ;; to discussed on the lectures about STREAMS (6A-6B) of SICP at MIT. 9 | 10 | (defpackage :lazy 11 | (:use :cl) 12 | (:export :lazy 13 | :force 14 | :lazy-cons 15 | :lazy-car 16 | :lazy-cdr 17 | :lazy-nil 18 | :lazy-null 19 | :make-lazy 20 | :take 21 | :take-all 22 | :lazy-mapcar 23 | :lazy-mapcan 24 | :lazy-find-if 25 | :lazy-nth 26 | :*integers*)) 27 | 28 | (in-package :lazy) 29 | 30 | (defmacro lazy (&body body) 31 | (let ((forced (gensym)) 32 | (value (gensym))) 33 | `(let ((,forced nil) 34 | (,value nil)) 35 | (lambda () 36 | (unless ,forced 37 | (setf ,value (progn ,@body)) 38 | (setf ,forced t)) 39 | ,value)))) 40 | 41 | (defun force (lazy-value) 42 | (funcall lazy-value)) 43 | 44 | 45 | (defmacro lazy-cons (a b) 46 | `(lazy (cons ,a ,b))) 47 | 48 | (defun lazy-car (x) 49 | (car (force x))) 50 | 51 | (defun lazy-cdr (x) 52 | (cdr (force x))) 53 | 54 | (defparameter *foo* (lazy-cons 4 7)) ;; => CLOSURE LAMBDA 55 | (lazy-car *foo*) ;; => 4 56 | (lazy-cdr *foo*) ;; => 7 57 | 58 | 59 | (defparameter *integers* (labels ((f (n) 60 | (lazy-cons n (f (1+ n))))) 61 | (f 1))) 62 | 63 | (lazy-car *integers*) ;; => 1 64 | (lazy-car (lazy-cdr *integers*)) ;; => 2 65 | (lazy-car (lazy-cdr (lazy-cdr *integers*))) ;; => 3 66 | 67 | ;; YES! INFINITE SEQUENCES! This is the lazy evaluation power 68 | ;; Only computes the value when needs. No recursive stack overflow. 69 | 70 | 71 | (defun lazy-nil () 72 | (lazy nil)) 73 | 74 | (defun lazy-null (x) 75 | (not (force x))) 76 | 77 | 78 | (defun make-lazy (list) 79 | (lazy (when list 80 | (cons (car list) 81 | (make-lazy (cdr list)))))) 82 | 83 | 84 | (defun take (n list) 85 | (unless (or (zerop n) 86 | (lazy-null list)) 87 | (cons (lazy-car list) 88 | (take (1- n) (lazy-cdr list))))) 89 | 90 | (take 100 *integers*) ;; => '(1 2 3 4 5 6 7 8 9 10) 91 | 92 | (defun take-all (list) 93 | (unless (lazy-null list) 94 | (cons (lazy-car list) 95 | (take-all (lazy-cdr list))))) 96 | 97 | (take 10 (make-lazy '(q w e r t y u i o p a s d f))) 98 | ;; => (Q W E R T Y U I O P) 99 | 100 | (take-all (make-lazy '(q w e r t y u i o p a s d f))) 101 | ;; => (Q W E R T Y U I O P A S D F) 102 | 103 | 104 | (defun lazy-mapcar (fun list) 105 | (lazy (unless (lazy-null list) 106 | (cons (funcall fun (lazy-car list)) 107 | (lazy-mapcar fun (lazy-cdr list)))))) 108 | 109 | (defun lazy-mapcan (fun list) 110 | (labels ((f (list-cur) 111 | (if (lazy-null list-cur) 112 | (force (lazy-mapcan fun (lazy-cdr list))) 113 | (cons (lazy-car list-cur) 114 | (lazy (f (lazy-cdr list-cur))))))) 115 | (lazy (unless (lazy-null list) 116 | (f (funcall fun (lazy-car list))))))) 117 | 118 | (defun lazy-find-if (fun list) 119 | (unless (lazy-null list) 120 | (let ((x (lazy-car list))) 121 | (if (funcall fun x) 122 | x 123 | (lazy-find-if fun (lazy-cdr list)))))) 124 | 125 | (defun lazy-nth (n list) 126 | (if (zerop n) 127 | (lazy-car list) 128 | (lazy-nth (1- n) (lazy-cdr list)))) 129 | 130 | 131 | ;; NOTE: Analogous functions mapcar, mapcan, find-if and nth for lazy lists. 132 | (take 10 (lazy-mapcar #'sqrt *integers*)) 133 | ;; => (1.0 1.4142135 1.7320508 2.0 2.236068 2.4494898 2.6457512 2.828427 3.0 3.1622777) 134 | 135 | (take 10 (lazy-mapcan (lambda (x) 136 | (if (evenp x) 137 | (make-lazy (list x)) 138 | (lazy-nil))) 139 | *integers*)) 140 | ;; => (2 4 6 8 10 12 14 16 18 20) 141 | 142 | (lazy-find-if #'oddp (make-lazy '(2 4 6 7 8 10))) 143 | ;; => 7 144 | 145 | (lazy-nth 4 (make-lazy '(a b c d e f g))) 146 | ;; => E 147 | -------------------------------------------------------------------------------- /land-of-lisp/cap16-magic-with-macros.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | #| MACRO PROGRAMMING 5 | 6 | Allows you to mess around inside your Lisp compiler to turn Lisp into 7 | your own custom programming language. When faced with a difficult programming 8 | challenge, many experienced Lispers will first ask themselves: 9 | 10 | "What programming language could I use to make this problem easy to solve?" 11 | 12 | Then they'll use macros to convert Lisp into that language! 13 | |# 14 | 15 | ;; A Simple Lisp Macro 16 | 17 | ;; fancy let1 (simple let) 18 | (defmacro let1 (var val &body body) 19 | `(let ((,var ,val)) 20 | ,@body)) 21 | 22 | (let ((foo (+ 2 3))) 23 | (* foo foo)) 24 | 25 | (let1 foo (+ 2 3) 26 | (* foo foo)) 27 | 28 | (macroexpand '(let1 foo (+ 2 3) 29 | (* foo foo))) 30 | ;; .. EXPANSION .. 31 | ;; (LET ((FOO (+ 2 3))) 32 | ;; (* FOO FOO)) 33 | 34 | ;; More Complex Macros 35 | 36 | ;; Warning! Contains Bugs! 37 | (defmacro split (val yes no) 38 | `(if ,val 39 | (let ((head (car ,val)) 40 | (tail (cdr ,val))) 41 | ,yes) 42 | ,no)) 43 | 44 | (split '(1 2) 45 | (format t "head - tail <=> ~a - ~a" head tail) 46 | (format t "no head tail")) 47 | 48 | ;; Avoid Repeated Execution in Macros 49 | 50 | (macroexpand '(split (progn (princ "Lisp rocks!") 51 | '(2 3)) 52 | (format t "This can be split into ~a and ~a." head tail) 53 | (format t "This cannot be split."))) 54 | 55 | #| => 56 | (IF #1=(PROGN (PRINC "Lisp rocks!") '(2 3)) 57 | (LET ((HEAD (CAR #1#)) (TAIL (CDR #1#))) 58 | (FORMAT T "This can be split into ~a and ~a." HEAD TAIL)) 59 | (FORMAT T "This cannot be split.")) 60 | |# 61 | ;; the result above is optimized by SBCL 62 | ;; in another implementation, like SBCL, the val will be evaluated 63 | ;; two times, at which (princ "Lisp rocks!") will be printed three times 64 | 65 | ;; explicitly evaluation just one-time of val 66 | ;; Warning! Still contains bugs 67 | (defmacro split (val yes no) 68 | `(let1 x ,val 69 | (if x 70 | (let ((head (car x)) 71 | (tail (cdr x))) 72 | ,yes) 73 | ,no))) 74 | 75 | ;; (let1 x 100 76 | ;; (split '(2 3) 77 | ;; (+ x head) 78 | ;; nil)) 79 | ;; ERROR! '(2 3) is not a number 80 | 81 | (macroexpand '(split '(2 3) 82 | (+ x head) 83 | nil)) 84 | #| EXPANSION 85 | 86 | (LET ((X '(2 3))) 87 | (IF X 88 | (LET ((HEAD (CAR X)) (TAIL (CDR X))) 89 | (+ X HEAD)) 90 | NIL)) 91 | |# 92 | 93 | ;; So x <- 100 receive the new states '(2 3) 94 | ;; after the 'split macro expansion. 95 | ;; Pretty bad. 96 | 97 | 98 | ;; Use of gensym 99 | 100 | ;; This function is finally safe to use 101 | (defmacro split (val yes no) 102 | (let1 g (gensym) 103 | `(let1 ,g ,val 104 | (if ,g 105 | (let ((head (car ,g)) 106 | (tail (cdr ,g))) 107 | ,yes) 108 | ,no)))) 109 | 110 | 111 | (defun pairs (lst) 112 | (labels ((f (lst acc) 113 | (split lst 114 | (if tail 115 | (f (cdr tail) 116 | (cons (cons head (car tail)) 117 | acc)) 118 | (reverse acc)) 119 | (reverse acc)))) 120 | (f lst nil))) 121 | 122 | (pairs '(a b c d e f)) 123 | ;; => ((A . B) (C . D) (E . F)) 124 | 125 | (defmacro recurse (vars &body body) 126 | (let1 p (pairs vars) 127 | `(labels ((self ,(mapcar #'car p) 128 | ,@body)) 129 | (self ,@(mapcar #'cdr p))))) 130 | 131 | (recurse (n 10) 132 | (fresh-line) 133 | (if (= n 1) 134 | (princ "CANCER") 135 | (progn (princ n) 136 | (self (1- n))))) 137 | 138 | ;; my-length function using black magic macros 139 | (defun my-length (lst) 140 | (recurse (lst lst 141 | acc 0) 142 | (split lst 143 | (self tail (1+ acc)) 144 | acc))) 145 | 146 | (my-length '(1 2 3)) 147 | 148 | ;; functional way (alternative to macro techniques) 149 | (defun my-length (lst) 150 | (reduce (lambda (x _) 151 | (declare (ignore _)) 152 | (1+ x)) 153 | lst 154 | :initial-value 0)) 155 | -------------------------------------------------------------------------------- /land-of-lisp/cap17-domain-specific-languages.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; On this chapter we'll create a SVG handler DSL using macros 5 | ;; Remember SVG (Scalable Vector Graphics) are XML-like, 6 | 7 | 8 | (defpackage :svg 9 | (:use :cl) 10 | (:export :svg :html 11 | :body :tag 12 | :brightness :svg-style 13 | :polygon :circle)) 14 | 15 | (in-package :svg) 16 | 17 | 18 | ;; Would be better avoid copy-paste functions, 19 | ;; but the chapter 16 has several re-definitions 20 | ;; and top-level execution of demonstrations 21 | ;; So i just adapted the +SPLIT and +PAIRS functions 22 | 23 | (defmacro split (val yes no) 24 | "Exported from the chapter 16" 25 | (let ((g (gensym))) 26 | `(let ((,g ,val)) 27 | (if ,g 28 | (let ((head (car ,g)) 29 | (tail (cdr ,g))) 30 | ,yes) 31 | ,no)))) 32 | 33 | 34 | (defun pairs (lst) 35 | "Exported from the chapter 16" 36 | (labels ((f (lst acc) 37 | (split lst 38 | (if tail 39 | (f (cdr tail) 40 | (cons (cons head (car tail)) 41 | acc)) 42 | (reverse acc)) 43 | (reverse acc)))) 44 | (f lst nil))) 45 | 46 | ;; so we need create tags 47 | (defun print-tag (name alist closingp) 48 | (princ #\<) 49 | (when closingp 50 | (princ #\/)) 51 | (princ (string-downcase name)) 52 | (mapc (lambda (att) 53 | (format t " ~a=\"~a\"" 54 | (string-downcase (car att)) 55 | (cdr att))) 56 | alist) 57 | (princ #\>)) 58 | 59 | 60 | (defmacro tag (name atts &body body) 61 | `(progn (print-tag ',name 62 | (list ,@(mapcar (lambda (x) 63 | `(cons ',(car x) 64 | ,(cdr x))) 65 | (pairs atts))) 66 | nil) 67 | ,@body 68 | (print-tag ',name nil t))) 69 | 70 | ;; using syntax-sugar for html 71 | 72 | (defmacro html (&body body) 73 | `(tag html () 74 | ,@body)) 75 | 76 | (defmacro body (&body body) 77 | `(tag body () 78 | ,@body)) 79 | 80 | (defmacro svg (&body body) 81 | `(tag svg (xmlns "http://www.w3.org/2000/svg" 82 | "xmlns:xlink" "http://www.w3.org/1999/xlink") 83 | ,@body)) 84 | 85 | (defun brightness (col amt) 86 | (mapcar (lambda (x) 87 | (min 255 (max 0 (+ x amt)))) 88 | col)) 89 | 90 | (defun svg-style (color) 91 | (format nil 92 | "~{fill:rgb(~a,~a,~a);stroke:rgb(~a,~a,~a)~}" 93 | (append color 94 | (brightness color -100)))) 95 | 96 | (defun circle (center radius color) 97 | (tag circle (cx (car center) 98 | cy (cdr center) 99 | r radius 100 | style (svg-style color)))) 101 | 102 | (defun polygon (points color) 103 | (tag polygon (points (format nil 104 | "~{~a, ~a ~}" 105 | (mapcan (lambda (tp) 106 | (list (car tp) (cdr tp))) 107 | points)) 108 | style (svg-style color)))) 109 | 110 | 111 | (defun random-walk (value length) 112 | (unless (zerop length) 113 | (cons value 114 | (random-walk (if (zerop (random 2)) 115 | (1- value) 116 | (1+ value)) 117 | (1- length))))) 118 | 119 | 120 | ;; create random polygons at random_walk.svg 121 | 122 | (defun random-walk-svg () 123 | (with-open-file (*standard-output* "random_walk.svg" 124 | :direction :output 125 | :if-exists :supersede) 126 | (svg (loop repeat 10 127 | do (polygon (append '((0 . 200)) 128 | (loop for x from 0 129 | for y in (random-walk 100 400) 130 | collect (cons x y)) 131 | '((400 . 200))) 132 | (loop repeat 3 133 | collect (random 256))))))) 134 | 135 | 136 | ;; svg finished 137 | 138 | ;; starts extension of the wizard_game from chapter 5-6 139 | -------------------------------------------------------------------------------- /mit-6.001/5B-computational-objects.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; digital circuit builder 5 | ;; computational objects using state and assignment (previous lecture) 6 | ;; 7 | ;; 8 | ;; |\ 9 | ;; ----| *--- (inverter) 10 | ;; |/ 11 | ;; ____ 12 | ;; ---| \ 13 | ;; | |-- (and-gate) 14 | ;; ---|____/ 15 | ;; _______ 16 | ;; \ \ 17 | ;; | |-- (or-gate) 18 | ;; ___/___/ 19 | ;; 20 | 21 | ;; agenda primitives 22 | ;; (make-agenda) 23 | ;; (current-time agenda) 24 | ;; (empty-agenda? agenda) 25 | ;; (add-to-agenda! time action agenda) 26 | ;; (first-item agenda) 27 | ;; (remove-first-item agenda) 28 | 29 | ;; implementing the agenda is George problem. 30 | 31 | (defparameter the-agenda (make-agenda)) 32 | (defparameter inverter-delay 2) 33 | (defparameter and-gate-delay 3) 34 | (defparameter or-gate-delay 5) 35 | 36 | (defun after-delay (delay action) 37 | (add-to-agenda! 38 | (+ delay (current-time the-agenda)) 39 | action 40 | the-agenda)) 41 | 42 | (defun propagate () 43 | (cond ((empty-agenda? the-agenda) 'done) 44 | (t (progn (funcall (first-item the-agenda)) 45 | (remove-first-item! the-agenda) 46 | (propagate))))) 47 | 48 | (defun call-each (procedures) 49 | (cond ((null procedures) 'done) 50 | (t (progn (funcall (car procedures)) 51 | (call-each (cdr procedures)))))) 52 | 53 | (defun get-signal (wire) 54 | (wire 'get-signal)) 55 | 56 | (defun set-signal! (wire new-value) 57 | (apply (wire 'set-signal!) '(new-value))) 58 | 59 | (defun add-action! (wire action-proc) 60 | (apply (wire 'add-action!) '(action-proc))) 61 | 62 | (defun make-wire () 63 | (let ((signal 0) 64 | (action-procs '())) 65 | (labels ((set-my-signal! (new) 66 | (cond ((= signal new) 'done) 67 | (t (progn (setq signal new) 68 | (call-each action-procs))))) 69 | (accept-action-proc (proc) 70 | (setq action-procs (cons proc action-procs)) 71 | (proc)) 72 | (dispatch (m) 73 | (cond ((eq m 'get-signal) signal) 74 | ((eq m 'set-signal) set-my-signal!) 75 | ((eq m 'add-action) 76 | accept=action-proc) 77 | (t (error "Bad message" m))))) 78 | dispatch))) 79 | 80 | (defun error (&rest messages) 81 | (loop for m in messages do (princ m))) 82 | 83 | (defun logical-not (s) 84 | (cond ((= s 0) 1) 85 | ((= s 1) 0) 86 | (t (error *invalid-signal* s)))) 87 | 88 | (defun logical-and (s1 s2) 89 | (cond ((and (eq s1 1) 90 | (eq s2 1)) 1) 91 | (t 0))) 92 | 93 | (defun logical-or (s1 s2) 94 | (cond ((or (eq s1 1) 95 | (eq s2 1)) 1) 96 | (t 0))) 97 | 98 | 99 | (defun inverter (in out) 100 | (labels ((inverter-in () 101 | (let ((new (logical-not (get-signal in)))) 102 | (after-dealy inverter-delay (lambda () (set-signal out new)))))) 103 | (add-action! in invert-in))) 104 | 105 | (defun and-gate (a1 a2 output) 106 | (labels ((and-action-procedure () 107 | (let ((new-value (logical-and (get-signal a1) 108 | (get-signal a2)))) 109 | (after-delay and-gate-delay 110 | (lambda () 111 | (set-signal! output 112 | new-value)))))) 113 | (add-action! a1 and-action-procedure) 114 | (add-action! a2 and-action-procedure))) 115 | 116 | (defun or-gate (a1 a2 output) 117 | (labels ((or-action-procedure () 118 | (let ((new-value (logical-or (get-signal a1) 119 | (get-signal a2)))) 120 | (after-delay or-gate-delay 121 | (lambda () 122 | (set-signal! output 123 | new-value)))))) 124 | (add-action! a1 or-action-procedure) 125 | (add-action! a2 or-action-procedure))) 126 | 127 | (defparameter a (make-wire)) 128 | (defparameter b (make-wire)) 129 | (defparameter c (make-wire)) 130 | (defparameter d (make-wire)) 131 | (defparameter e (make-wire)) 132 | (defparameter s (make-wire)) 133 | 134 | (or-gate a b d) 135 | (and-gate a b c) 136 | (inverter c e) 137 | (and-gate d e s) 138 | 139 | (defun half-adder (a b s c) 140 | (let ((d (make-wire)) 141 | (e (make-wire))) 142 | (or-gate a b d) 143 | (and-gate a b c) 144 | (inverter c e) 145 | (and-gate d e s))) 146 | 147 | (defun full-adder (a b c-in sum c-out) 148 | (let ((s (make-wire)) 149 | (c1 (make-wire)) 150 | (c2 (make-wire))) 151 | (half-adder b c-in s c1) 152 | (half-adder a s sum c2) 153 | (or-gate c1 c2 c-out))) 154 | 155 | 156 | ;; Bonus => Lambda Calculus Mutable Data 157 | ;; Redefining Cons with only lambdas 158 | 159 | (defun cons-lambda (x y) 160 | (lambda (m) 161 | (apply m '(x 162 | y 163 | (lambda (n) (setq x y)) 164 | (lambda (n) (setq y n)))))) 165 | 166 | (defun car-lambda (c) 167 | (apply c (list (lambda (a d sa sd) a)))) 168 | 169 | (defun cdr-lambda (c) 170 | (apply c (list (lambda (a d sa sd) d)))) 171 | 172 | (defun set-car! (c n) 173 | (apply c (list (lambda (a d sa sd) (sa n))))) 174 | 175 | (defun set-cdr! (c n) 176 | (apply c (list (lambda (a d sa sd) (sd n))))) 177 | -------------------------------------------------------------------------------- /land-of-lisp/cap12-streams.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | #| 5 | :: => STREAMS 6 | 7 | Streams are data types in Common Lisp that allow you 8 | to take some external resource and make it look like 9 | just another simple piece of data you can manipulate with 10 | your code. 11 | 12 | Types of streams: 13 | * file stream: 14 | Let us read and write to files on our hard drive 15 | * string stream: 16 | Let us send and receive text from a Lisp string 17 | * console stream: 18 | REPL and terminals 19 | * socket stream: 20 | Let us communicate with other computers on a network 21 | 22 | Streams by direction: 23 | * output stream 24 | * input stream 25 | |# 26 | 27 | 28 | ;; Output Streams: 29 | ;; + Check whether the stream is valid 30 | ;; + Push a new item onto the stream 31 | 32 | ;; check if stream is valid 33 | (output-stream-p *standard-output*) 34 | ;; => T 35 | 36 | ;; push a new item on stream 37 | (write-char #\x *standard-output*) 38 | ;; STDOUT => x 39 | ;; => #\x 40 | 41 | 42 | ;; Input Streams 43 | ;; + check whether the stream is valid. 44 | ;; + pop an item off of the stream 45 | 46 | ;; check if the stream is valid 47 | (input-stream-p *standard-input*) 48 | ;; => T 49 | 50 | ;; pop item from stream 51 | (read-char *standard-input*) 52 | ;; INPUT => 123 53 | ;; => #\1 54 | 55 | ;; NOTE: Using other commands to interact with streams 56 | (print 'foo *standard-output*) 57 | 58 | 59 | ;; :: Working With Files 60 | 61 | ;; write on file 62 | (with-open-file (my-stream "data.txt" :direction :output) 63 | (print "my data" my-stream)) 64 | ;; => "my data" 65 | ;; a new file called data.txt is created 66 | 67 | 68 | ;; read a file 69 | (with-open-file (my-stream "data.txt" :direction :input) 70 | (read my-stream)) 71 | ;; => "my data" 72 | 73 | 74 | ;; another example 75 | (let ((animal-noises '((dog . woof) 76 | (cat . meow)))) 77 | (with-open-file (my-stream "animal-noises.txt" :direction :output) 78 | (print animal-noises my-stream))) 79 | ;; => ((DOG . WOOF) (CAT . MEOW)) 80 | 81 | (with-open-file (my-stream "animal-noises.txt" :direction :input) 82 | (read my-stream)) 83 | ;; => ((DOG . WOOF) (CAT . MEOW)) 84 | 85 | ;; using keywords of with-open-file form to throw errors 86 | ;; when a file already exists on direction output 87 | (with-open-file (my-stream "data.txt" :direction :output 88 | :if-exists :error) 89 | (print "my data" my-stream)) 90 | ;; *** - OPEN: file #P"/home/.../data.txt" already exists 91 | 92 | ;; use :supersede to force overwritten when :if-exists is true 93 | (with-open-file (my-stream "data.txt" :direction :output 94 | :if-exists :supersede) 95 | (print "my data" my-stream)) 96 | ;; => "my data" 97 | 98 | ;; NOTE: 99 | ;; The with-open-file macro is very similar to the context-manager of python 100 | ;; which is created using the `with` keyword on this language. 101 | ;; As well implement on Python, the with-open-file already cares about open 102 | ;; and closing the files gracefully. That way we don't need worry about that. 103 | ;; On Common Lisp, in general, all the `with-' commands using this prefix 104 | ;; will safely allocate resources in this way. 105 | 106 | 107 | ;; :: Working with Sockets 108 | 109 | ;; A socket is a mechanism for routing data over a computer network 110 | ;; between programs running on different computers on that network. 111 | ;; Sockets are not in the ANSI Common Lisp standard, which means 112 | ;; there's no standard way of interacting with sockets at this time. 113 | 114 | ;; libs: :cl-sockets or :usocket 115 | ;; cl-sockets is not in quicklisp, but usocket are. 116 | ;; in this section I'll use the usocket 117 | ;; https://github.com/usocket/usocket 118 | ;; running through SBCL 119 | ;; (ql:quickload 'usocket) 120 | 121 | ;; Every socket within a network must have a socket address: 122 | ;; + IP address 123 | ;; + Port number 124 | 125 | 126 | ;; -> Socket Connections 127 | ;; Steps: 128 | ;; 1. A program to create a socket that starts in a listening state (server) 129 | ;; 2. A program to create a socket its end and uses it to establish a connection with the server (client) 130 | ;; If all goes well, these two programs can now transmit messages across the socket connection running between them 131 | 132 | ;; This example will be write on the client and server files. 133 | ;; + cap12-socket-server.lisp 134 | ;; + cap12-socket-client.lisp 135 | 136 | 137 | ;; :: String Streams: The Oddball Type 138 | (defparameter foo (make-string-output-stream)) 139 | (princ "This will go into foo. " foo) 140 | (princ "This will also go into foo. " foo) 141 | (get-output-stream-string foo) 142 | 143 | 144 | ;; :: Reading and Debugging 145 | ;; Another reason for using string streams is that they can make our code 146 | ;; easier to read and debug, especially when we use the with-output-to- 147 | ;; string macro 148 | 149 | ;; Here's an example 150 | 151 | (with-output-to-string (*standard-output*) 152 | (princ "the sum of ") 153 | (princ 5) 154 | (princ " and ") 155 | (princ 2) 156 | (princ " is ") 157 | (princ (+ 2 5))) 158 | ;; => the sum of 5 and 2 is 7 159 | 160 | ;; The with-output-to-string macro will intercept any text that would 161 | ;; otherwise be output to the console, REPL, or other output stream, 162 | ;; and capture it as a string. 163 | 164 | ;; As a exercise of this chapter about streams as well about sockets, 165 | ;; I've wrote a experimental repository of chat-like system through 166 | ;; the local network at www.github.com/ryukinix/lisp-chat 167 | 168 | 169 | 170 | -------------------------------------------------------------------------------- /land-of-lisp/cap13-webserver.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; :: Writing a Web Server from Scratch 5 | 6 | ;; -> How a Web Server Works 7 | 8 | ;; Hypertext Transfer Protocol, or HTTP, is the internet protocol 9 | ;; used for transferring web pages. It adds a layer on top of TCP/IP 10 | ;; for requesting pages once a socket connection has been established. 11 | ;; When a program running on a client computer (usually a web browser) 12 | ;; sends a properly encoded request, the server will retrieve the requested 13 | ;; page and send it over the socket stream in response. 14 | 15 | ;; NOTE: this web server is adapted from 'http.lisp' created by Ron Garret. 16 | 17 | ;; Decoding the Values of Request Parameters 18 | (ql:quickload 'usocket) 19 | 20 | (defpackage :webserver 21 | (:use :cl :usocket) 22 | (:export :serve)) 23 | 24 | (in-package :webserver) 25 | 26 | (defun http-char (c1 c2 &optional (default #\Space)) 27 | (let ((code (parse-integer 28 | (coerce (list c1 c2) 'string) 29 | :radix 16 30 | :junk-allowed t))) 31 | (if code 32 | (code-char code) 33 | default))) 34 | 35 | (defun decode-param (s) 36 | (labels ((f (list) 37 | (when list 38 | (case (car list) 39 | (#\% (cons (http-char (cadr list) (caddr list)) 40 | (f (cdddr list)))) 41 | (#\+ (cons #\space (f (cdr list)))) 42 | (otherwise (cons (car list) (f (cdr list)))))))) 43 | (coerce (f (coerce s 'list)) 44 | 'string))) 45 | 46 | ;; Unit tests 47 | (decode-param "foo") 48 | ;; => "foo" 49 | (decode-param "foo%3F") 50 | ;; => "foo?" 51 | (decode-param "foo+bar") 52 | ;; => "foo bar" 53 | 54 | ;; :: Decoding lists of request parameters 55 | 56 | (defun parse-params (s) 57 | (let ((i1 (position #\= s)) 58 | (i2 (position #\& s))) 59 | (cond (i1 (cons (cons (intern (string-upcase (subseq s 0 i1))) 60 | (decode-param (subseq s (1+ i1) i2))) 61 | (and i2 (parse-params (subseq s (1+ i2)))))) 62 | ((equal s "") nil) 63 | (t s)))) 64 | 65 | (parse-params "name=bob&age=25&gender=male") 66 | ;; => ((NAME . "bob") (AGE . "25") (GENDER . "male")) 67 | 68 | ;; NOTE: Both decode-param and parse-params could achieve higher performance 69 | ;; if they were written using a tail call, as we'll discuss in Chapter 14 70 | 71 | (defun parse-url (s) 72 | (let* ((url (subseq s 73 | (+ 2 (position #\space s)) 74 | (position #\space s :from-end t))) 75 | (x (position #\? url))) 76 | (if x 77 | (cons (subseq url 0 x) (parse-params (subseq url (1+ x)))) 78 | (cons url '())))) 79 | 80 | (parse-url "GET /lolcats.html HTTP/1.1") 81 | ;; => ("lolcats.html") 82 | (parse-url "GET /lolcats.html?extra-funny=yes HTTP/1.1") 83 | ;; => ("lolcats.html" (EXTRA-FUNNY . "yes")) 84 | 85 | 86 | (defun get-header (stream) 87 | (let* ((s (read-line stream)) 88 | (h (let ((i (position #\: s))) 89 | (when i 90 | (cons (intern (string-upcase (subseq s 0 i))) 91 | (subseq s (+ i 2))))))) 92 | (when h 93 | (cons h (get-header stream))))) 94 | 95 | ;; :: Testing get-header with a String stream 96 | 97 | (get-header (make-string-input-stream "foo: 1 98 | bar: abc, 123 99 | 100 | ")) 101 | ;; => ((FOO . "1") (BAR . "abc, 123")) 102 | ;; In that example we simulated a socket stream using a string stream with 103 | ;; input direction. Nice! 104 | 105 | ;; => Parse the Request Body 106 | 107 | (defun get-content-params (stream header) 108 | (let ((length (cdr (assoc 'content-length header)))) 109 | (when length 110 | (let ((content (make-string (parse-integer length)))) 111 | (read-sequence content stream) 112 | (parse-params content))))) 113 | 114 | 115 | ;; The server function is briefly modified to working with SBCL and USOCKET 116 | 117 | (defun serve (request-handler) 118 | (let ((socket (socket-listen "localhost" 8080))) 119 | (unwind-protect 120 | (loop (with-open-stream (stream (socket-stream (socket-accept socket))) 121 | (let* ((url (parse-url (read-line stream))) 122 | (path (car url)) 123 | (header (get-header stream)) 124 | (params (append (cdr url) 125 | (get-content-params stream header))) 126 | (*standard-output* stream)) 127 | (funcall request-handler path header params)))) 128 | (socket-close socket)))) 129 | 130 | 131 | ;; :: Building a Dynamic Website 132 | 133 | ;; To try out our shiny new web server, let's build a simple site that 134 | ;; greets a visitor, using the dirt-simple function hello-request-handler 135 | 136 | (defun hello-request-handler (path header params) 137 | (declare (ignore header)) 138 | (if (equal path "greeting") 139 | (let ((name (assoc 'name params))) 140 | (if (not name) 141 | (princ "
What is your name? 142 |
") 143 | (format t "Nice to meet you, ~a!" (cdr name)))) 144 | (princ "ERROR 404 - Sorry... I don't know that page"))) 145 | 146 | ;; (hello-request-handler "lolcats" '() '()) 147 | ;; => ERROR 404 - Sorry... I don't know that page 148 | 149 | ;; (hello-request-handler "greeting" '() ()) 150 | ;; =>
What is your name?
151 | 152 | ;; Executing the server... 153 | ;; (serve #'hello-request-handler) 154 | ;; You can access this server on 155 | ;; 127.0.0.1:8080/greeting 156 | 157 | ;; We now have a fully functioning web server and request handling infrastructure. 158 | -------------------------------------------------------------------------------- /land-of-lisp/cap10-life-simulation.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defparameter *width* 100) 5 | (defparameter *height* 30) 6 | (defparameter *jungle* '(45 10 10 10)) 7 | (defparameter *plant-energy* 80) 8 | (defparameter *reproduction-energy* 200) 9 | 10 | ;; PLANTS WITH (X . Y) KEY COORDINATES HASH-MAP 11 | (defparameter *plants* (make-hash-table :test #'equal)) 12 | ;; need to use #'equal here because the default #'eq 13 | ;; doesn't works fine to compare cons cells. 14 | 15 | 16 | (defun random-plant (left top width height) 17 | (let ((pos (cons (+ left (random width)) 18 | (+ top (random height))))) 19 | (setf (gethash pos *plants*) t))) 20 | 21 | (defun add-plants () 22 | (apply #'random-plant *jungle*) 23 | (random-plant 0 0 *width* *height*)) 24 | 25 | 26 | ;; x y => cartesian location 27 | ;; energy => days left of life 28 | ;; dir => direction as a number between 0 and 7. 29 | ;; 0 1 2 30 | ;; 7 * 3 31 | ;; 6 5 4 32 | ;; genes => list of eight elements 33 | ;; the list of probabilities bounds for decide the daily direction 34 | ;; greater number, more likely to be chosen 35 | (defstruct animal x y energy dir genes) 36 | 37 | 38 | (defparameter *animals* 39 | (list (make-animal :x (ash *width* -1) 40 | :y (ash *height* -1) 41 | :energy 100 42 | :dir 0 43 | :genes (loop repeat 8 44 | collecting (1+ (random 10)))))) 45 | 46 | (defun move (animal) 47 | (let ((dir (animal-dir animal)) 48 | (x (animal-x animal)) 49 | (y (animal-y animal))) 50 | (setf (animal-x animal) (mod (+ x 51 | (cond ((and (>= dir 2) 52 | (< dir 5)) 1) 53 | ((or (= dir 1) 54 | (= dir 5)) 0) 55 | (t -1)) 56 | *width*) 57 | *width*)) 58 | (setf (animal-y animal) (mod (+ y 59 | (cond ((and (>= dir 0) 60 | (< dir 3)) 1) 61 | ((or (>= dir 4) 62 | (< dir 7)) -1) 63 | (t 0)) 64 | *height*) 65 | *height*)) 66 | (decf (animal-energy animal)))) 67 | 68 | (defun turn (animal) 69 | (let ((x (random (apply #'+ (animal-genes animal))))) 70 | (labels ((angle (genes x) 71 | (let ((xnu (- x (car genes)))) 72 | (if (< xnu 0) 73 | 0 74 | (1+ (angle (cdr genes) xnu)))))) 75 | (setf (animal-dir animal) 76 | (mod (+ (animal-dir animal) 77 | (angle (animal-genes animal) x)) 78 | 8))))) 79 | 80 | (defun eat (animal) 81 | (let ((pos (cons (animal-x animal) 82 | (animal-y animal)))) 83 | (when (gethash pos *plants*) 84 | (incf (animal-energy animal) *plant-energy*) 85 | (remhash pos *plants*)))) 86 | 87 | 88 | (defun reproduce (animal) 89 | (let ((e (animal-energy animal))) 90 | (when (>= e *reproduction-energy*) 91 | (setf (animal-energy animal) (ash e -1)) 92 | (let ((animal-nu (copy-structure animal)) 93 | (genes (copy-list (animal-genes animal))) 94 | (mutation (random 8))) 95 | (setf (nth mutation genes) 96 | (max 1 (+ (nth mutation genes) 97 | (random 3) 98 | -1))) 99 | (setf (animal-genes animal-nu) genes) 100 | (push animal-nu *animals*))))) 101 | 102 | (defun update-world () 103 | (setf *animals* (remove-if (lambda (animal) 104 | (<= (animal-energy animal) 0)) 105 | *animals*)) 106 | (mapc (lambda (animal) 107 | (turn animal) 108 | (move animal) 109 | (eat animal) 110 | (reproduce animal)) 111 | *animals*) 112 | (add-plants)) 113 | 114 | (defun draw-world () 115 | (loop for y 116 | below *height* 117 | do (progn (fresh-line) 118 | (princ "|") 119 | (loop for x 120 | below *width* 121 | do (princ (cond ((some (lambda (animal) 122 | (and (= (animal-x animal) x) 123 | (= (animal-y animal) y))) 124 | *animals*) 125 | #\M) 126 | ((gethash (cons x y) *plants*) #\*) 127 | (t #\space)))) 128 | (princ "|")))) 129 | 130 | (defun evolution () 131 | (draw-world) 132 | (fresh-line) 133 | (let ((str (read-line))) 134 | (cond ((equal str "quit") 'nil) 135 | (t (let ((x (parse-integer str :junk-allowed t))) 136 | (if x 137 | (loop for i 138 | below x 139 | do (update-world) 140 | if (zerop (mod i 1000)) 141 | do (princ #\.)) 142 | (update-world)) 143 | (evolution)))))) 144 | 145 | (format t "At each step: 1. type a integer to let evolution for n days, 'quit' for exit and just RETURN to update.. ~%") 146 | (format t "* => PLANT ~%") 147 | (format t "M => ANIMAL ~%") 148 | (evolution) 149 | -------------------------------------------------------------------------------- /mit-6.001/9B-explicit-control-evaluator.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; A review about language design using Lisp, what we've done until now: 5 | ;; Picture language by Peter Henderson 6 | ;; Digital Logic Language 7 | ;; Query Language (Logic Programming like Prolog) 8 | 9 | ;; CONCRETE COMPUTATION HERE! 10 | 11 | 12 | ;; ======> LISP 13 | 14 | ;; Meta-circular evaluator was based on Lisp for Lisp. Eval/Apply solving fixed-point equations 15 | 16 | 17 | ;; This stuff seems magic, but right now we'll destroy all the magic using the register machine 18 | 19 | ;; again, primitives: DATA-PATHS, FINITE-STATE CONTROLLER AND STACK 20 | 21 | 22 | 23 | ;; lisp-user -> chars => reader => lisp memory structure => eval => 24 | ;; primitive-operations => printer => lisp-user 25 | 26 | #| 27 | :: REGISTER USAGE IN EVALUATOR MACHINE :: 28 | 29 | EXP expression to be evaluated 30 | ENV evaluation environment 31 | 32 | FUN procedure to be applied 33 | ARGL list of evaluated arguments 34 | 35 | CONTINUE place to go to next 36 | 37 | VAL result of evaluation 38 | 39 | UNEV temporary register for expressions 40 | 41 | |# 42 | 43 | #| 44 | SAMPLE EVALUATOR-MACHINE OPERATIONS 45 | (assign val (fetch exp)) 46 | 47 | (branch (conditional? (fetch exp)) 48 | ev-cond) 49 | 50 | (assign exp (first-clause (fetch-exp))) 51 | 52 | (assign val (look-variable-value (fetch exp) 53 | (fetch env))) 54 | |# 55 | 56 | 57 | ;; evaluator for LISP in LISP 58 | ;; using abstract syntax from SICP book (little different of lecture from Gerald) 59 | (defun eval. (exp env) 60 | (cond ((self-evaluating ? exp) exp) 61 | ((quoted? exp) 62 | (text-of-quotation exp)) 63 | ... 64 | ((application? exp) 65 | (apply 66 | (eval (operator exp) env) 67 | (list-of-values (operands exp) 68 | env))) 69 | (t (error 'unknown-expression)))) 70 | 71 | 72 | (defun apply. (proc args) 73 | (cond ((primitive-proc? proc) 74 | (primitive-apply proc args)) 75 | ((compound-proc? proc) 76 | (eval-sequence (proc-body proc) 77 | (extend-environment 78 | (parameters proc) 79 | args 80 | (proc-environment proc)))) 81 | (t (error unknown-proc-type)))) 82 | 83 | 84 | ;; eval/apply cicle :: eval => procedure, arguments => 85 | ;; apply => expression, environment => 86 | ;; eval 87 | 88 | 89 | #| 90 | :: CONTRACT THAT EVAL-DISPATCH FULFILLS :: 91 | 92 | - The EXP register holds an expression to 93 | be evaluated; 94 | 95 | - The ENV register holds the environment in which the expression 96 | is to be evaluated; 97 | 98 | - The CONTINUE register holds a place to go to next; 99 | 100 | - The result will be left in the VAL register. Contents of all 101 | other registers may be destroyed; 102 | 103 | |# 104 | 105 | 106 | #| 107 | 108 | :: CONTRACT THAT APPLY-DISPATCH FULFILLS :: 109 | 110 | - The ARGL register contains a list of arguments; 111 | 112 | - The FUN register contains a procedure to be applied; 113 | 114 | - The top of the STACK holds a place to go to next; 115 | 116 | - The result will be left in the VAL register. The stack will be 117 | popped. Contents of all other registers may be destroyed; 118 | 119 | |# 120 | 121 | (load "9A-register-machines.lisp") 122 | 123 | (define-machine eval-dispatch 124 | (branch (self-evaluating? (fetch exp)) 125 | ev-self-eval) 126 | (branch (variable? (fetch exp)) 127 | ev-variable) 128 | 129 | < more especial forms > 130 | 131 | (branch (application? (fetch exp)) 132 | ev-appliations) 133 | (goto unknow-expression-error)) 134 | 135 | (define-machine ev-self-eval 136 | (assign val (fetch exp)) 137 | (goto (fetch continue))) 138 | 139 | 140 | (define-machine ev-variable 141 | (assign val (lookup-variable-value (fetch exp))) 142 | (goto (fetch continue))) 143 | 144 | 145 | (define-machine ev-application 146 | (assign unev (operands (fetch exp))) 147 | (assign exp (oeprator (fetch exp))) 148 | (save continue) 149 | (save env) 150 | (save unev) 151 | (assign continu eval-args) 152 | (goto eval-dispatch)) 153 | 154 | 155 | (define-machine eval-args 156 | (restore unev) 157 | (restore env) 158 | (assign fun (fetch val)) 159 | (save fun) 160 | (assign argl '()) 161 | (goto eval-arg-loop)) 162 | 163 | (define-machine eval-arg-loop 164 | (save argl) 165 | (assign exp (first-operand (fetch unev))) 166 | (branch (last-operand? (fetch (unev))) 167 | (eval-last-arg)) 168 | (save env) 169 | (save unev) 170 | (assign continue accumulate-arg) 171 | (goto eval-dispatch)) 172 | 173 | (define-machine accumulate-arg 174 | (restore unev) 175 | (restore env) 176 | (restore argl) 177 | (assign argl (cons (fetch val) 178 | (fetch arg1))) 179 | (assign unev (rest-operands (fetch unev))) 180 | (goto eval-arg-loop)) 181 | 182 | (define-machine apply-dispatch 183 | (branch (primitive-proc? (fetch fun) 184 | primitive-apply)) 185 | (branch (compound-proc? (fetch fun) 186 | compound-apply)) 187 | (goto unknown-proc-type-error)) 188 | 189 | 190 | (define-machine primitive-apply 191 | (assign val (apply-primitive-proc (fetch fun) 192 | (fetch argl))) 193 | (restore continue) 194 | (goto (fetch continue))) 195 | 196 | 197 | (define-machine compound-apply 198 | (assign exp (procedure-body (fetch fun))) 199 | (assign env (make-bindings (fetch fun) 200 | (fetch arg1))) 201 | (restore continue) 202 | (goto eval-dispatch)) 203 | 204 | (defun f (a b) 205 | (+ a b)) 206 | ;; 207 | (defvar x 3) 208 | (defvar y 4) 209 | 210 | (f x y) 211 | 212 | (defun fact-rec (n) 213 | (if (<= n 1) 214 | 1 215 | (* n 216 | (fact-rec (1- n))))) 217 | 218 | -------------------------------------------------------------------------------- /mit-6.001/6A-streams-I.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | ;; THIS LECTURE IS ABOUT STREAMS AND GENERATORS 6 | 7 | 8 | ;; previous concepts defined: 9 | ;; * STATE 10 | ;; * ASSIGNMENT 11 | ;; * CHANGE (VARIABLE) 12 | ;; * TIME 13 | ;; * IDENTITY (ABOUT CAR/CDRS) 14 | ;; * OBJECT 15 | ;; * SHARING (STATE) 16 | 17 | 18 | ;; without using streams and high abstract procedures, solve that two problems: 19 | ;; sum-odd-squares on tree and sum the odd fib numbers from a interval [n, m] 20 | 21 | 22 | (defun leaf-node? (tree) 23 | (atom tree)) 24 | 25 | (defun square (n) 26 | (* n n)) 27 | 28 | (defun left-branch (tree) 29 | (car tree)) 30 | 31 | (defun right-branch (tree) 32 | (cdr tree)) 33 | 34 | (defun sum-odd-squares (tree) 35 | (if (leaf-node? tree) 36 | (if (and (numberp tree) (oddp tree)) 37 | (square tree) 38 | 0) 39 | (+ (sum-odd-squares 40 | (left-branch tree)) 41 | (sum-odd-squares 42 | (right-branch tree))))) 43 | 44 | ;; tail cail optimized, from O(2^n) => O(n) 45 | (defun fib (n) 46 | (labels ((tail-call-fib (n acc1 acc2) 47 | (if (= n 0) 48 | acc1 49 | (tail-call-fib (1- n) acc2 (+ acc1 acc2))))) 50 | (tail-call-fib n 0 1))) 51 | 52 | (defun odd-fibs (n) 53 | (labels ((next (k) 54 | (if (> k n) 55 | nil 56 | (let ((f (fib k))) 57 | (if (oddp f) 58 | (cons f (next (1+ k))) 59 | (next (1+ k))))))) 60 | (next 1))) 61 | 62 | ;; However, we can imagine that problems in a signal processing evaluation, like that 63 | 64 | ;; sum-odd-squares 65 | ;; enumerates-leaves => filter-odd => map-square => (acc '+ '0) 66 | 67 | ;; odd-fibs 68 | ;; enum-interval => map-fib => filter-odd => (acc 'cons '()) 69 | 70 | ;; This is like streams, so we will define data abstraction for streams 71 | ;; primitives 72 | ;; (cons-stream x y) 73 | ;; (head s) 74 | ;; (tail s) 75 | ;; (the-empty-stream) 76 | 77 | ;; for any x and y 78 | ;; (head (cons-stream x y)) => x 79 | ;; (tail (cons-stream x y)) => y 80 | 81 | ;; this seems very likely cons, car and cdr, right? 82 | ;; but not! streams are lazy evaluated 83 | 84 | 85 | (defun delay (x) 86 | (lambda () x)) 87 | 88 | (defun force (x) 89 | (let* ((exp (funcall x)) 90 | (func (car exp)) 91 | (args (cdr exp))) 92 | (apply func args))) 93 | 94 | ;; i tried define this as macro to avoid the quotation for y, 95 | ;; but just doesn't works T_T 96 | ;; old version :: 97 | ;; (defmacro cons-stream (x delayed) 98 | ;; `(cons ,x (delay (list ,@delayed)))) 99 | ;; the code fails on enumerate-tree about 100 | ;; (cons tree the-empty-stream) ;; => (cons tree (list nil)) 101 | (defun cons-stream (x y) 102 | (cons x (delay y))) 103 | 104 | (defun head (x) 105 | (car x)) 106 | 107 | (defun tail (x) 108 | (force (cdr x))) 109 | 110 | (defparameter the-empty-stream '()) 111 | 112 | (defun empty-stream? (x) 113 | (null x)) 114 | 115 | (defun map-stream (proc s) 116 | (if (empty-stream? s) 117 | the-empty-stream 118 | (cons-stream 119 | (funcall proc (head s)) 120 | `(map-stream ,proc ,(tail s))))) 121 | 122 | (defun filter (pred s) 123 | (cond ((empty-stream? s) the-empty-stream) 124 | ((funcall pred (head s)) 125 | (cons-stream (head s) 126 | `(filter ,pred 127 | ,(tail s)))) 128 | (t (filter pred (tail s))))) 129 | 130 | (defun accumulate (combiner init-val s) 131 | (if (empty-stream? s) 132 | init-val 133 | (funcall combiner (head s) 134 | (accumulate combiner 135 | init-val 136 | (tail s))))) 137 | 138 | (defun append-streams (s1 s2) 139 | (if (empty-stream? s1) 140 | s2 141 | (cons-stream (head s1) 142 | `(append-streams ,(tail s1) 143 | ,s2)))) 144 | 145 | (defun enumerate-tree (tree) 146 | (if (leaf-node? tree) 147 | (cons-stream tree 148 | the-empty-stream) 149 | (append-streams 150 | (enumerate-tree 151 | (left-branch tree)) 152 | (enumerate-tree 153 | (right-branch tree))))) 154 | 155 | (defun enum-interval (low high) 156 | (if (> low high) 157 | the-empty-stream 158 | (cons-stream low `(enum-interval ,(1+ low) ,high)))) 159 | 160 | 161 | (defun sum-odd-squares-stream (tree) 162 | (accumulate #'+ 0 163 | (mapcar #'square 164 | (filter #'oddp 165 | (enumerate-tree tree))))) 166 | 167 | 168 | (defun odd-fibs-stream (n) 169 | (accumulate #'cons '() 170 | (filter #'oddp 171 | (mapcar #'fib (enum-interval 1 n))))) 172 | 173 | 174 | (defun flatten (st-of-st) 175 | (accumulate #'append-streams 176 | the-empty-stream 177 | st-of-st)) 178 | 179 | (defun flat-map (f s) 180 | (flatten (map-stream f s))) 181 | 182 | 183 | (defun prime? (n) 184 | (let ((divisors (loop for x from 2 to (round (sqrt n)) collect x))) 185 | (loop for div in divisors never (eq (mod n div) 0)))) 186 | 187 | (defun prime-sum-pairs (n) 188 | (map-stream #'(lambda (p) 189 | (list (car p) 190 | (cadr p) 191 | (+ (car p) (cadr p)))) 192 | (filter 193 | (lambda (p) 194 | (prime? (+ (car p) (cadr p)))) 195 | (flat-map #'(lambda (i) 196 | (map-stream (lambda (j) (list i j)) 197 | (enum-interval 1 (1- i)))) 198 | (enum-interval 1 n))))) 199 | 200 | (defun range (a b) 201 | (enum-interval a b)) 202 | 203 | (defun eval-stream (s) 204 | (if (empty-stream? s) 205 | nil 206 | (cons (head s) (eval-stream (tail s))))) 207 | 208 | (eval-stream (range 1 10)) 209 | 210 | (prime? 13) 211 | (head (tail (filter #'prime? (enum-interval 10000 100000000000000)))) 212 | -------------------------------------------------------------------------------- /mit-6.001/4A-pattern-matching.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; WARNING: THIS CODE WAS COPIED DIRECTLY FROM SICP AND I DON'T TESTED IT 5 | 6 | ;; In the original SICP lectures instead the symbol '=>' is used the colon ':' 7 | ;; however that char is reserved at least on SBCL and a error is dispatched when 8 | ;; this is evaluated 9 | (defparameter deriv-rules '(;; constant 10 | ((dd (?c c) (? x)) 0) 11 | ;; same var 12 | ((dd (?v x) (? x)) 1) 13 | ;; another var 14 | ((dd (?v y) (? x)) 0) 15 | ;; sum rule 16 | ((dd (+ (? x1) (? x2)) (? x)) 17 | (+ (dd (=> x1) (=> x)) 18 | (dd (=> x2) (=> x)))) 19 | ;; multiplication rule 20 | ((dd (* (? x1) (? x2)) (? x)) 21 | (+ (* (=> x1) (dd (=> x2) (=> x))) 22 | (* (=> x2) (dd (=> x1) (=> x))))) 23 | ;; exponentiation rule 24 | ((dd (** (? fx) (? n)) (? x)) 25 | (* (* (=> n) 26 | (** (=> fx) (1- (=> n)))) 27 | (dd (=> fx) (=> x)))))) 28 | 29 | (defparameter algebra-rules '(;; if the operands are constants, evaluate it 30 | ;; (+ 1 2) => 3 31 | (((? op) (?c e1) (?c e2)) 32 | (=> (op e1 e2))) 33 | 34 | ;; if second operand is constant and first not, swap 35 | ;; (+ x 1) => (+ 1 x) 36 | (((? op) (? e1) (?c e2)) 37 | ((=> op) (=> e2) (=> e1) )) 38 | 39 | ;; if something sums 0, return that thing 40 | ;; (+ 0 x) => x 41 | ((+ 0 (? e)) (=> e)) 42 | 43 | ;; if something multiplies 1, just return that 44 | ;; (* 1 x) => x 45 | ((* 1 (? e)) (=> e)) 46 | 47 | ;; anything multiplied by zero is zero 48 | ;; (* 0 x) => 0 49 | ((* 0 (? e)) 0) 50 | 51 | ;; constant multiplication 52 | ;; (* 2 (* 2 x)) => (* 4 x) 53 | ((* (?c e1) (* (?c e2) (? e3))) 54 | (* (=> (* e1 e2)) (=> e3))) 55 | 56 | ;; aesthetic multiplication simplification 57 | ;; (* x (* 5 y)) => (* 5 (* x y)) 58 | ((* (? e1 (* (?c e2) (? e3)))) 59 | (* (=> e2) (* (=> e1) (=> e3)))) 60 | 61 | ;; sum evaluation if is possible 62 | ;; (+ 5 (+ 3 x)) => (+ 8 x) 63 | ((+ (?c e1) (+ (?c e2) (? e3))) 64 | (+ (=> (+ e1 e2)) (=> e3))) 65 | 66 | ;; aesthetic sum simplification 67 | ;; (+ x (+ 2 y)) => (+ 2 (+ x y)) 68 | (((+ (? e1) (+ (?c e2) (? e3))) 69 | (+ (=> e2) (+ (=> e1) (=> e3))))) 70 | 71 | ;; commutative multiplication property 72 | ;; (* (* x y) z) => (* x (* y z)) 73 | ((* (* (? e1) (? e2)) (? e3)) 74 | (* (=> e1) (* (=> e2) (=> e3)))) 75 | 76 | ;; commutative sum property 77 | ;; (+ (+ x y) z) => (+ x (+ y z)) 78 | ((+ (+ (? e1) (? e2)) (? e3)) 79 | (+ (=> e1) (+ (=> e2) (=> e3)))) 80 | 81 | ;; algebraic sum 82 | ;; (+ (* 2 x) (* 4 x)) => (* 6 x) 83 | ((+ (* (?c a) (? x)) (* (?c b) (? x))) 84 | (* (=> (+ a b)) (=> x))) 85 | 86 | ;; distribution rule of product over sum 87 | ((* (? c) (+ (? d) (? e))) 88 | (+ (* (=> c) (=> d)) 89 | (* (=> c) (=> e)))))) 90 | 91 | ;; matcher machine 92 | ;; pattern 93 | ;; ↓ 94 | ;; +---------+ 95 | ;; | | 96 | ;; expression → | MATCHER | → dict 97 | ;; | | 98 | ;; +---------+ 99 | ;; ↑ 100 | ;; dict 101 | ;; 102 | 103 | (defparameter empty-dictionary '()) 104 | 105 | (defun extend-dictionary (pat dat dict) 106 | (let* ((name (variable-name pat)) 107 | (v (assq name dict))) 108 | (cond ((null v) 109 | (cons (list name dat) dict)) 110 | ((eq (cadr v) dat) dict) 111 | (t 'failed)))) 112 | 113 | (defun lookup (var dict) 114 | (let ((v (assq var dict))) 115 | (if (null v) 116 | var 117 | (cadr v)))) 118 | 119 | (defun match (pat exp dict) 120 | (cond ((eq dict 'failed) 'failed) 121 | ((atom pat) 122 | (if (atom exp) 123 | (if (eq pat exp) 124 | dict 125 | 'failed) 126 | 'failed)) 127 | ((arbitrary-constants? pat) 128 | (if (constant? exp) 129 | (extend-dict pat exp dict) 130 | 'failed)) 131 | ((arbitrary-variable? pat) 132 | (if (variable? exp) 133 | (extend-dict pat exp dict) 134 | 'failed)) 135 | ((arbirary-expression? pat) 136 | (extend-dict pat exp dict)) 137 | ((atom exp) 'failed) 138 | (t (match (cdr pat) 139 | (cdr exp) 140 | (match (car pat) 141 | (car exp) 142 | dict))))) 143 | 144 | (defun instantiate (skeleton dict) 145 | (defun loop-inst (s) 146 | (cond ((atom s) s) 147 | ((skeleton-evaluation? s) 148 | (evaluate (eval-exp s) dict)) 149 | (t (cons (loop-inst (car s)) 150 | (loop-inst (cdr s)))))) 151 | (loop-inst skeleton)) 152 | 153 | (defun evaluate (form dict) 154 | (if (atom form) 155 | (lookup form dict) 156 | (apply 157 | (eval (lookup (car form) dict) 158 | user-initial-environment) 159 | (mapcar (lambda (v) 160 | (lookup v dict)) 161 | (cdr form))))) 162 | 163 | 164 | (defun simplifier (the-rules) 165 | (defun try-rules (exp) 166 | (defun scan (rules) 167 | (if (null rules) 168 | exp 169 | (let ((dict (match (pattern (car rules)) 170 | exp 171 | (empty-dictionary)))) 172 | (if (eq dict 'failed) 173 | (scan (cdr rules)) 174 | (simplify-exp 175 | (instantiate 176 | (skeleton (car rules)) 177 | dict)))))) 178 | (scan the-rules)) 179 | (defun simplify-parts (exp) 180 | (if (null exp) 181 | '() 182 | (cons (simplify-exp (car exp)) 183 | (simplify-parts (cdr exp))))) 184 | (defun simplify-exp (exp) 185 | (try-rules (if (compound? exp) 186 | (simplify-parts exp) 187 | exp))) 188 | 189 | simplify-exp) 190 | 191 | 192 | (setf (symbol-function 'dsimp) (simplifier deriv-rules)) 193 | -------------------------------------------------------------------------------- /land-of-lisp/cap7-beyond-basic-lists.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (defpackage :graph-util 5 | (:use :cl) 6 | (:export :graph->png 7 | :ugraph->png 8 | :main)) 9 | 10 | (in-package :graph-util) 11 | 12 | 13 | ;; associative lists 14 | (defparameter *drink-order* '((bill . double-espresso) 15 | (lisa . samll-drip-coffee) 16 | (john . medium-latte))) 17 | 18 | ;; visualizing tree-like data 19 | (defparameter *house* '((walls (mortar (cement) 20 | (water) 21 | (sand)) 22 | (bricks)) 23 | (windows (glass) 24 | (frame) 25 | (curtains) 26 | (roof (shingles) 27 | (chinmey))))) 28 | ;; this is in someway can be hard to visualize the relations of data 29 | 30 | 31 | ;; lets create a graph 32 | (defparameter *wizard-nodes* '((living-room (you are in the living-room. 33 | a wizard is snoring loudly on the couch.)) 34 | (garden (you are in a beatiful garden. 35 | there is a wall in front of you.)) 36 | (attic (you are in the attic. there 37 | is a giant welding torch in the corner.)))) 38 | 39 | (defparameter *wizard-edges* '((living-room (garden west door) 40 | (attic upstairs ladder)) 41 | (garden (living-room east door)) 42 | (attic (living-room downstairs ladder)))) 43 | 44 | 45 | (defparameter *max-label-length* 30) 46 | 47 | ;; * generating the dot information 48 | 49 | 50 | ;; ** converting node identifiers 51 | 52 | (defun dot-name (exp) 53 | (substitute-if #\_ (complement #'alphanumericp) (prin1-to-string exp))) 54 | 55 | 56 | (defun dot-label (exp) 57 | (if exp 58 | (let ((s (write-to-string exp :pretty nil))) ;; :pretty nil avoid modify the original exp 59 | (if (> (length s) *max-label-length*) 60 | (concatenate 'string (subseq s 0 (- *max-label-length* 3)) "...") 61 | s)) 62 | "")) 63 | 64 | 65 | (defun nodes->dot (nodes) 66 | (mapc (lambda (node) 67 | (fresh-line) 68 | (princ (dot-name (car node))) 69 | (princ "[label=\"") 70 | (princ (dot-label node)) 71 | (princ "\"];")) 72 | nodes)) 73 | 74 | 75 | (defun edges->dot (edges) 76 | (mapc (lambda (node) 77 | (mapc (lambda (edge) 78 | (fresh-line) ;; wtf is that? 79 | (princ (dot-name (car node))) 80 | (princ "->") 81 | (princ (dot-name (car edge))) 82 | (princ "[label=\"") 83 | (princ (dot-label (cdr edge))) 84 | (princ "\"];")) 85 | (cdr node))) 86 | edges)) 87 | 88 | 89 | (defun graph->dot (nodes edges) 90 | (princ "digraph{") 91 | (nodes->dot nodes) 92 | (edges->dot edges) 93 | (princ "}")) 94 | 95 | 96 | (defun dot->png (fname thunk) 97 | (with-open-file (*standard-output* 98 | fname 99 | :direction :output 100 | :if-exists :supersede) 101 | (funcall thunk)) 102 | ;; generate graph using fname calling dot 103 | (sb-ext:run-program "dot" (list "-Tpng" "-O" fname) :search t :wait t) 104 | 105 | ;; delete the file 106 | (sb-ext:run-program "rm" (list fname) :search t :wait t)) 107 | 108 | 109 | ;; thunk definition: nullary functions, with zero arguments 110 | ;; can be called suspension too 111 | 112 | 113 | ;; note: symbols with prefixed colon are constants, like => :direction :output and so on 114 | 115 | ;; (let ((:cigar 5)) 116 | ;; :cigar) 117 | ;; => 118 | ;; Compile-time error: 119 | ;; :CIGAR is a keyword, and cannot be used as a local variable. 120 | ;; [Condition of type SB-INT:COMPILED-PROGRAM-ERROR] 121 | 122 | 123 | (defun graph->png (fname nodes edges) 124 | (dot->png fname 125 | (lambda () 126 | (graph->dot nodes edges)))) 127 | 128 | 129 | ;; creating undirected graphs 130 | 131 | (defun uedges->dot (edges) 132 | (maplist (lambda (lst) ;; ? maplist? 133 | (mapc (lambda (edge) 134 | (unless (assoc (car edge) (cdr lst)) 135 | (fresh-line) 136 | (princ (dot-name (caar lst))) 137 | (princ "--") 138 | (princ (dot-name (car edge))) 139 | (princ "[label=\"") 140 | (princ (dot-label (cdr edge))) 141 | (princ "\"];"))) 142 | (cdar lst))) 143 | edges)) 144 | 145 | (defun ugraph->dot (nodes edges) 146 | (princ "graph{") 147 | (nodes->dot nodes) 148 | (uedges->dot edges) 149 | (princ "}")) 150 | 151 | (defun ugraph->png (fname nodes edges) 152 | (dot->png fname 153 | (lambda () 154 | (ugraph->dot nodes edges)))) 155 | 156 | (defun main() 157 | 158 | (in-package :graph-util) 159 | ;; exotic lists 160 | 161 | (cons 1 (cons 2 (cons 3 nil))) 162 | '(1 2 3) 163 | '(1 . (2 . (3 . nil))) 164 | 165 | ;; representations of lists above are equivalents in its implementation 166 | ;; just conses of cells. 167 | 168 | ;; association lists (dotted lists) 169 | (assoc 'lisa *drink-order*) 170 | (push '(lisa . large-mocha-with-whipped-cream) *drink-order*) 171 | (assoc 'lisa *drink-order*) 172 | 173 | ;; circular lists 174 | ;; (let ((foo '(1 2 3))) 175 | ;; (setf (cdddr foo) foo)) ;; circle list!! 176 | 177 | ;; substitute-if higher-order function 178 | (substitute-if 0 #'oddp '(1 2 3 4 5 6 7 8 9 10)) 179 | ;; => (0 2 0 4 0 6 0 8 0 10) 180 | 181 | ;; complement higher-order function 182 | ;; (complement #'oddp) <=> (lambda (x) (not (oddp x))) 183 | 184 | (nodes->dot *wizard-nodes*) 185 | ;; => LIVING_ROOM[label="(LIVING-ROOM (YOU ARE IN TH..."]; 186 | ;; => GARDEN[label="(GARDEN (YOU ARE IN A BEATI..."]; 187 | ;; => ATTIC[label="(ATTIC (YOU ARE IN THE ATTI..."]; 188 | 189 | (dot-label (expt 10 35)) 190 | ;; => "100000000000000000000000000..." 191 | (subseq '(1 2 3 4) 0 2) 192 | ;; => (1 2) 193 | (graph->dot *wizard-nodes* *wizard-edges*) 194 | ;; => 195 | ;; digraph{ 196 | ;; LIVING_ROOM[label="(LIVING-ROOM (YOU ARE IN TH..."]; 197 | ;; GARDEN[label="(GARDEN (YOU ARE IN A BEATI..."]; 198 | ;; ATTIC[label="(ATTIC (YOU ARE IN THE ATTI..."]; 199 | ;; LIVING_ROOM->GARDEN[label="(WEST DOOR)"]; 200 | ;; LIVING_ROOM->ATTIC[label="(UPSTAIRS LADDER)"]; 201 | ;; GARDEN->LIVING_ROOM[label="(EAST DOOR)"]; 202 | ;; ATTIC->LIVING_ROOM[label="(DOWNSTAIRS LADDER)"];} 203 | (edges->dot *wizard-edges*) 204 | ;; => LIVING_ROOM->GARDEN[label="(WEST DOOR)"]; 205 | ;; => LIVING_ROOM->ATTIC[label="(UPSTAIRS LADDER)"]; 206 | ;; => GARDEN->LIVING_ROOM[label="(EAST DOOR)"]; 207 | ;; => ATTIC->LIVING_ROOM[label="(DOWNSTAIRS LADDER)"]; 208 | 209 | ;; writes "Hello File!" into "testfile.txt" 210 | (with-open-file (my-stream 211 | "testfile.txt" 212 | :direction :output ;; ?? 213 | :if-exists :supersede) ;; ?!?!? 214 | (princ "Hello File!" my-stream)) 215 | ;; :direction :output => we're only writing to the file and not reading it 216 | ;; :if-exists :supersede => if a file by that name already exists, just too out the old version 217 | 218 | 219 | (graph->png "wizard-graph.dot" *wizard-nodes* *wizard-edges*) 220 | (ugraph->png "wizard-graph-undirected.dot" 221 | *wizard-nodes* 222 | *wizard-edges*) 223 | 224 | ;; wow, this works! GREAT. 225 | 226 | ;; maplist iterating by cdr 227 | ;; maplist itearting by car 228 | ;; map needs a selector 229 | (mapcar #'print '(a b c)) 230 | ;; => 231 | ;; A 232 | ;; B 233 | ;; C 234 | 235 | (maplist #'print '(a b c)) 236 | ;; => 237 | ;; (A B C) 238 | ;; (B C) 239 | ;; (C) 240 | ) 241 | ;; EOF 242 | -------------------------------------------------------------------------------- /mit-6.001/7B-metacircular-evaluator-II.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (load "7A-metacircular-evaluator-I.lisp") 5 | 6 | #| 7 | == META-CIRCULAR EVALUATOR PART ii == 8 | 9 | A weird interpreter of Lisp written in Lisp to run it in Lisp. Why so much Lisp? I even know what I writing. 10 | Well, let me press the play button for the lecture 7B. 11 | 12 | |# 13 | 14 | 15 | (defun take-many-arguments (x &rest y) 16 | (mapcar #'(lambda (u) (* u x)) 17 | y)) 18 | 19 | (take-many-arguments 5 1 2 3 4 5) 20 | 21 | 22 | ;; some strange modification was done here to support 23 | ;; function lambdas with variadic params 24 | (defun pair-up (vars vals) 25 | (cond ((eq vars '()) 26 | (cond ((eq vals '()) '()) 27 | (t (error 'TMA)))) 28 | ((symbolp vars) 29 | (cons (cons vars vals) '())) 30 | ((eq vals '()) 31 | (error 'TFA)) 32 | (t (cons (cons (car vars) 33 | (car vals)) 34 | (pair-up (cdr vars) 35 | (cdr vals)))))) 36 | 37 | (defun sum (term a next b) 38 | (if (> a b) 39 | 0 40 | (+ (funcall term a) 41 | (sum term 42 | (funcall next a) 43 | next 44 | b)))) 45 | 46 | (defun product (term a next b) 47 | (if (> a b) 48 | 0 49 | (* (funcall term a) 50 | (product term 51 | (funcall next a) 52 | next 53 | b)))) 54 | 55 | (defun sum-powers (a b n) 56 | (sum (lambda (x) (expt x n)) 57 | a 58 | #'1+ 59 | b)) 60 | 61 | (defun product-powers (a b n) 62 | (product (lambda (x) (expt x n)) 63 | a 64 | #'1+ 65 | b)) 66 | 67 | ;; this is not so nice, we have code replication. Hour to do some abstraction here 68 | 69 | ;; => POC 70 | 71 | (defun nth-power (x) 72 | (expt x n)) ;; a problem here, n is isolated into this environment, n => free variable 73 | ;; but how can nth-power know if n is a bound variable when is called? 74 | 75 | ;; the name of that problem is dynamic binding. 76 | 77 | (defun sum-powers (a b n) 78 | (sum #'nth-power a #'1+ b)) 79 | ;; nth-power, with dynamical binding, we try look for the value of n into the environment of caller. 80 | ;; which in that case is sum-of-powers, so will n from nth-power bind to n to sum-powers function body. 81 | 82 | ;; similarly to product we have 83 | 84 | (defun product-powers (a b n) 85 | (product #'nth-power a #'1+ b)) 86 | 87 | ;; for that works we need change the way of +eval from the last lecture is implemented, here is the new +eval: 88 | 89 | ;; we'll kill the lexical scope and statical binding for that, so closures are dead. 90 | 91 | (defun +eval (exp env) 92 | (cond ((numberp exp) exp) 93 | ((symbolp exp) (lookup exp env)) 94 | ((eq (car exp) 'quote) (cadr exp)) 95 | ((eq (car exp) 'lambda) exp) ;; changes here, just return the lambda exp instead closure/env 96 | ((eq (car exp) 'cond) 97 | (evcond (cdr exp) env)) 98 | (t (+apply (+eval (car exp) env) 99 | (evlist (cdr exp) env) ;; also changes here 100 | env)))) 101 | 102 | ;; apply needs be changed too, and gets more complicated 103 | 104 | (defun +apply (proc args env) ;; now apply needs env as parameter! 105 | (cond ((primitive? proc) ;; magic, ignore 106 | (apply-primeop proc args)) 107 | ((eq (car proc) 'lambda) ;; if is lambda 108 | (+eval (caddr proc) ;; body 109 | (bind (cadr proc) ;; vars 110 | args 111 | env)) ;; env provide from the caller of function 112 | (t 'error-unknow-procedure)))) 113 | 114 | 115 | ;; dynamic binding has serious problems because breaks the problem of modularity 116 | ;; the scope is global for all!!!!!!!!!!! because closures will conflict of its internal variables 117 | ;; with the caller and so on 118 | 119 | ;; SO GO TO HELL WITH OF THIS TYPE OF ABSTRACTION HERE! 120 | ;; SCHEME AND COMMON LISP DON'T IMPLEMENTS DYNAMIC BINDING 121 | ;; (however seems JS do as well old lisp implementations) 122 | 123 | 124 | ;; by other hand, we can use a double closure to take n variable passing to them 125 | 126 | ;; pgen => procedure generator 127 | (defun pgen (n) 128 | (lambda (x) (expt x n))) 129 | 130 | (defun sum-powers (a b n) 131 | (sum #'(pgen n) 132 | a 133 | #'1+ 134 | b)) 135 | 136 | (defun product-powers (a b n) 137 | (product #'(pgen n) 138 | a 139 | #'1+ 140 | b)) 141 | 142 | ;; Oh, nice! Sussman talk about the lazy evaluation problem from streams 143 | ;; procedures commented in the earlier lectures. Yes, we have a problem passing in the 144 | ;; way is showed. The arguments, by default, is evaluated first before function call 145 | ;; in Lisp. 146 | 147 | (defun +unless (p c a) 148 | (cond ((not p) c) 149 | (t a))) 150 | 151 | ;; so 152 | 153 | (+unless (= 1 0) 2 (/ 1 0)) ;; is ok, huh? 154 | 155 | ;; NOooot! nOOOT! As Pingu would say. That not will return 2, because before that (/ 1 0) is 156 | ;; evaluated and that procedure call is giant a sin. A ARITHMETIC ERROR IS TROWED INTO YOUR FACE! 157 | 158 | 159 | ;; but if `c` and `a` was delayed automatically? 160 | 161 | 162 | ;; MODE : SCHEME 163 | #| 164 | 165 | (define (unless p (name a) (name c)) 166 | (cond ((not p) a) 167 | (t c))) 168 | 169 | |# 170 | 171 | ;; if this is implemented, we need change again our interpreter/compiler core 172 | 173 | ;; primitives for that type of thing 174 | (defun delay (x) 175 | (lambda () x)) 176 | 177 | (defun force (x) 178 | (funcall x)) 179 | 180 | (defun undelay (x) 181 | (cond ((and (pair? v) 182 | (eq (car v) 'thunk)) 183 | (undelay (eval (cadr v) 184 | (cddr v)))) 185 | (t v))) 186 | 187 | (defun make-delay (exp env) 188 | (cons 'thunk) (cons exp env)) 189 | 190 | (defun +eval (exp env) 191 | (cond ((numberp exp) exp) 192 | ((symbolp exp) (lookup exp env)) 193 | ((eq (car exp) 'quote) (cadr exp)) 194 | ((eq (car exp) 'lambda) 195 | (list 'closure (cdr exp) env)) 196 | ((eq (car exp) 'cond) 197 | (evcond (cdr exp) env)) 198 | (t (+apply (undelay (+eval (car exp) env)) ;; force undelay here 199 | (cdr exp) ;; btw, wtf is undelay? 200 | env)))) ;; we need that again 201 | 202 | (defun evlist (l env) 203 | (cond ((eq 1 '()) nil) 204 | (t (cons (undelay (eval (car l env))) 205 | (evlist (cdr l) env))))) 206 | 207 | (defun gevlist (vars exp env) 208 | (cond ((eq exps nil) nil) 209 | ((symbolp (car vars)) 210 | (cons (eval (car exps) env) 211 | (gevlist (cdr vars) 212 | (cdr exps) 213 | env))) 214 | ((eq? (caar vars) 'name) 215 | (cons (make-delay (car exps) env) 216 | (gevlist (cdr vars) 217 | (cdr exps) 218 | env))) 219 | (t (error 'error-unknown-declaration)))) 220 | 221 | (defun +apply (proc args env) ;; now apply needs env as parameter! 222 | (cond ((primitive? proc) ;; magic, ignore 223 | (apply-primeop proc (evlist args env))) 224 | ((eq (car proc) 'closure) ;; if is lambda 225 | ;; proc = (closure ((bvrs) body) env) 226 | (+eval (cadadr proc) ;; body 227 | (bind (vnames (caadr proc)) ;; vars 228 | (gevlist (caadr proc) 229 | args 230 | env) 231 | (caddr proc))) ;; env provide from the caller of function 232 | (t 'error-unknow-procedure)))) 233 | 234 | ;; evcond needs change too 235 | (defun evcond (clauses env) 236 | (cond ((eq clauses '()) '()) 237 | ((eq (caar clauses) t) 238 | (+eval (cadar clauses) env)) 239 | ((false? (undelay ;; because need predicate evaluates 240 | (+eval (caar clauses) 241 | env))) 242 | (evcond (cdr clauses) env)) 243 | (t (+eval (cadar clauses) env)))) 244 | 245 | 246 | 247 | ;; THIS FUCKING METACIRCULAR EVALUATOR IS REALLY OBSCURE!!! hahaha 248 | -------------------------------------------------------------------------------- /land-of-lisp/cap19-web-dice-of-doom-v3.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (load "cap13-webserver") ;; as :webserver package 5 | (load "cap17-domain-specific-languages") ;; as :svg package 6 | (load "cap18-dice-of-doom-v2") ;; as :dice-of-doom-v2 package 7 | (load "cap18-lazy-programming") ;; as :lazy package 8 | 9 | (defpackage :dice-of-doom-v3 10 | (:use :cl :svg :dice-of-doom-v2 :lazy :webserver) 11 | (:export :main 12 | :gen-board 13 | :attacking-moves 14 | :handle-human 15 | :handle-computer 16 | :get-ratings 17 | :limit-tree-depth 18 | :*num-players* 19 | :*die-colors* 20 | :*ai-level* 21 | :*board-width* :*board-height* 22 | :*board-scale* :*top-offset* 23 | :*dice-scale* :*dot-size*)) 24 | 25 | (in-package :dice-of-doom-v3) 26 | 27 | 28 | (defparameter *board-width* 900) 29 | (defparameter *board-height* 500) 30 | (defparameter *board-scale* 64) 31 | (defparameter *top-offset* 3) 32 | (defparameter *dice-scale* 40) 33 | (defparameter *dot-size* 0.05) 34 | (defparameter *die-colors* '((255 63 63) (63 63 255))) 35 | (defparameter *cur-game-tree* nil) 36 | (defparameter *from-tile* nil) 37 | 38 | (defun draw-die-svg (x y col) 39 | (labels ((calc-pt (pt) 40 | (cons (+ x (* *dice-scale* (car pt))) 41 | (+ y (* *dice-scale* (cdr pt))))) 42 | (f (pol col) 43 | (polygon (mapcar #'calc-pt pol) col))) 44 | (f '((0 . -1) (-0.6 . -0.75) (0 . -0.5) (0.6 . -0.75)) 45 | (brightness col 40)) 46 | (f '((0 . -0.5) (-0.6 . -0.75) (-0.6 . 0) (0 . 0.25)) 47 | col) 48 | (f '((0 . -0.5) (0.6 . -0.75) (0.6 . 0) (0 . 0.25)) 49 | (brightness col -40)) 50 | (mapc (lambda (x y) 51 | (polygon (mapcar (lambda (xx yy) 52 | (calc-pt (cons (+ x (* xx *dot-size*)) 53 | (+ y (* yy *dot-size*))))) 54 | '(-1 -1 1 1) 55 | '(-1 1 1 -1)) 56 | '(255 255 255))) 57 | '(-0.05 0.125 0.3 -0.3 -0.125 0.05 0.2 0.2 0.45 0.45 -0.45 -0.2) 58 | '(-0.875 -0.80 -0.725 -0.775 -0.70 -0.625 59 | -0.35 -0.05 -0.45 -0.15 -0.45 -0.05)))) 60 | 61 | (defun draw-tile-svg (x y pos hex xx yy col chosen-tile) 62 | (loop for z below 2 63 | do (polygon (mapcar (lambda (pt) 64 | (cons (+ xx (* *board-scale* (car pt))) 65 | (+ yy (* *board-scale* 66 | (+ (cdr pt) (* (- 1 z) 0.1)))))) 67 | 68 | '((-1 . -0.2) (0 . -0.5) (1 . -0.2) 69 | (1 . 0.2) (0 . 0.5) (-1 . 0.2))) 70 | (if (eql pos chosen-tile) 71 | (brightness col 100) 72 | col))) 73 | (loop for z below (second hex) 74 | do (draw-die-svg (+ xx 75 | (* *dice-scale* 76 | 0.3 77 | (if (oddp (+ x y z)) 78 | -0.3 79 | 0.3))) 80 | (- yy (* *dice-scale* z 0.8)) col))) 81 | 82 | (defun make-game-link (pos) 83 | (format nil "/game.html?chosen=~a" pos)) 84 | 85 | 86 | (defun draw-board-svg (board chosen-tile legal-tiles) 87 | (loop for y below *board-size* 88 | do (loop for x below *board-size* 89 | for pos = (+ x (* *board-size* y)) 90 | for hex = (aref board pos) 91 | for xx = (* *board-scale* (+ (* 2 x) (- *board-size* y))) 92 | for yy = (* *board-scale* (+ (* y 0.7) *top-offset*)) 93 | for col = (brightness (nth (first hex) *die-colors*) 94 | (* -15 (- *board-size* y))) 95 | do (if (member pos legal-tiles) 96 | (tag g () 97 | (tag a ("xlink:href" (make-game-link pos)) 98 | (draw-tile-svg x y pos hex xx yy col chosen-tile))) 99 | (draw-tile-svg x y pos hex xx yy col chosen-tile))))) 100 | 101 | 102 | (defun web-initialize () 103 | (setf *from-tile* nil) 104 | (setf *cur-game-tree* (game-tree (gen-board) 0 0 t))) 105 | 106 | (defun web-announce-winner (board) 107 | (fresh-line) 108 | (let ((w (winners board))) 109 | (if (> (length w) 1) 110 | (format t "The game is a tie between ~a" (mapcar #'player-letter w)) 111 | (format t "The winner is ~a" (player-letter (car w))))) 112 | (tag a (href "game.html") 113 | (princ " play again"))) 114 | 115 | (defun web-handle-human (pos) 116 | (cond ((not pos) (princ "Please choose a hex to move from:")) 117 | ((eq pos 'pass) (setf *cur-game-tree* 118 | (cadr (lazy-car (caddr *cur-game-tree*)))) 119 | (princ "Your reinforcements have been placed.") 120 | (tag a (href (make-game-link nil)) 121 | (princ "continue"))) 122 | ((not *from-tile*) (setf *from-tile* pos) 123 | (princ "Now choose a destination:")) 124 | ((eq pos *from-tile*) (setf *from-tile* nil) 125 | (princ "Move cancelled.")) 126 | (t (setf *cur-game-tree* 127 | (cadr (lazy-find-if (lambda (move) 128 | (equal (car move) 129 | (list *from-tile* pos))) 130 | (caddr *cur-game-tree*)))) 131 | (setf *from-tile* nil) 132 | (princ "You may now ") 133 | (tag a (href (make-game-link 'pass)) 134 | (princ "pass")) 135 | (princ " or make another move:")))) 136 | 137 | (defun web-handle-computer () 138 | (setf *cur-game-tree* (handle-computer *cur-game-tree*)) 139 | (princ "The computer has moved. ") 140 | (tag script () 141 | (princ "window.setTimeout('window.location=\"game.html?chosen=NIL\"',5000)"))) 142 | 143 | (defun draw-dod-page (tree selected-tile) 144 | (svg *board-width* 145 | *board-height* 146 | (draw-board-svg (cadr tree) 147 | selected-tile 148 | (take-all (if selected-tile 149 | (lazy-mapcar 150 | (lambda (move) 151 | (when (eql (caar move) 152 | selected-tile) 153 | (cadar move))) 154 | (caddr tree)) 155 | (lazy-mapcar #'caar (caddr tree))))))) 156 | 157 | 158 | 159 | (defun dod-request-handler (path header params) 160 | (declare (ignore header)) 161 | (if (equal path "game.html") 162 | (progn (html 163 | (body 164 | (tag center () 165 | (princ "Welcome to DICE OF DOOM!") 166 | (tag br ()) 167 | (let ((chosen (assoc 'chosen params))) 168 | (when (or (not *cur-game-tree*) 169 | (not chosen)) 170 | (setf chosen nil) 171 | (web-initialize)) 172 | (cond ((lazy-null (caddr *cur-game-tree*)) 173 | (web-announce-winner (cadr *cur-game-tree*))) 174 | ((zerop (car *cur-game-tree*)) 175 | (web-handle-human 176 | (when chosen 177 | (read-from-string (cdr chosen))))) 178 | (t (web-handle-computer)))) 179 | (tag br ()) 180 | (draw-dod-page *cur-game-tree* *from-tile*))))) 181 | (princ "Sorry... I don't know that page."))) 182 | 183 | 184 | (defun main () 185 | (serve #'dod-request-handler)) 186 | 187 | 188 | ;; NOTE: 189 | ;; UNFORTUNATELY THIS EXAMPLE DOESN'T WORKS ON MODERN BROWSERS 190 | ;; BECAUSE THE BAD IMPLEMENTATION OF :WEBSERVER WITHOUT SEND A STANDARD HEADER. 191 | 192 | ;; By the way, the svg drawing is fucked up too. GREAT. 193 | -------------------------------------------------------------------------------- /land-of-lisp/cap18-dice-of-doom-v2.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (load "cap15-dice-of-doom") ;; load as package dice-doom 5 | (load "cap18-lazy-programming") ;; load directly to cl-user 6 | 7 | (defpackage :dice-of-doom-v2 8 | (:use :cl :dice-of-doom :lazy) 9 | (:export :human 10 | :winners 11 | :computer 12 | :handle-computer 13 | :gen-board 14 | :game-tree 15 | :player-letter 16 | :*ai-level* 17 | :*num-players* 18 | :*max-dice* 19 | :*board-size* 20 | :*board-hexnum*)) 21 | 22 | (in-package dice-of-doom-v2) 23 | 24 | 25 | (defparameter *board-size* 4) 26 | (defparameter *board-hexnum* (* *board-size* 27 | *board-size*)) 28 | 29 | (defun add-passing-move (board player spare-dice first-move moves) 30 | (if first-move 31 | moves 32 | (lazy-cons (list nil 33 | (game-tree (add-new-dice board player 34 | (1- spare-dice)) 35 | (mod (1+ player) *num-players*) 36 | 0 37 | t)) 38 | moves))) 39 | 40 | 41 | (defun attacking-moves (board cur-player spare-dice) 42 | (labels ((player (pos) 43 | (car (aref board pos))) 44 | (dice (pos) 45 | (cadr (aref board pos)))) 46 | (lazy-mapcan 47 | (lambda (src) 48 | (if (eq (player src) cur-player) 49 | (lazy-mapcan 50 | (lambda (dst) 51 | (if (and (not (eq (player dst) 52 | cur-player)) 53 | (> (dice src) (dice dst))) 54 | (make-lazy 55 | (list (list (list src dst) 56 | (game-tree (board-attack board 57 | cur-player 58 | src 59 | dst 60 | (dice src)) 61 | cur-player 62 | (+ spare-dice (dice dst)) 63 | nil)))) 64 | (lazy-nil))) 65 | (make-lazy (neighbors src))) 66 | (lazy-nil))) 67 | (make-lazy (loop for n below *board-hexnum* 68 | collect n))))) 69 | 70 | (defun handle-human (tree) 71 | (fresh-line) 72 | (princ "choose your move:") 73 | (let ((moves (caddr tree))) 74 | (labels ((print-moves (moves n) 75 | (unless (null moves) ;; hacky fix 76 | (unless (lazy-null moves) 77 | (let* ((move (lazy-car moves)) 78 | (action (car move))) 79 | (fresh-line) 80 | (format t "~a. " n) 81 | (if action 82 | (format t "~a -> ~a" (car action) (cadr action)) 83 | (princ "end turn")))) 84 | (print-moves (lazy-cdr moves) (1+ n))))) 85 | (print-moves moves 1)) 86 | (fresh-line) 87 | (cadr (lazy-nth (1- (read)) moves)))) 88 | 89 | (defun play-vs-human (tree) 90 | (print-info tree) (if (not (lazy-null (caddr tree))) 91 | (play-vs-human (handle-human tree)) 92 | (announce-winner (cadr tree)))) 93 | 94 | 95 | (defun limit-tree-depth (tree depth) 96 | (list (car tree) 97 | (cadr tree) 98 | (if (zerop depth) 99 | (lazy-nil) 100 | (lazy-mapcar (lambda (move) 101 | (list (car move) 102 | (limit-tree-depth (cadr move) (1- depth)))) 103 | (caddr tree))))) 104 | 105 | 106 | (defparameter *ai-level* 4) ;; depth to look on tree of game 107 | 108 | ;; OLD NON-OPTIMIZED COMPUTER AI 109 | ;; (defun handle-computer (tree) 110 | ;; (let ((ratings (get-ratings (limit-tree-depth tree *ai-level*) 111 | ;; (car tree)))) 112 | ;; (cadr (lazy-nth (position (apply #'max ratings) ratings) 113 | ;; (caddr tree))))) 114 | 115 | 116 | (defun play-vs-computer (tree) 117 | (print-info tree) 118 | (cond ((lazy-null (caddr tree)) (announce-winner (cadr tree))) 119 | ((zerop (car tree)) (play-vs-computer (handle-human tree))) 120 | (t (play-vs-computer (handle-computer tree))))) 121 | 122 | (defun threatened (pos board) 123 | (let* ((hex (aref board pos)) 124 | (player (car hex)) 125 | (dice (cadr hex))) 126 | (loop for n in (neighbors pos) 127 | do (let* ((nhex (aref board n)) 128 | (nplayer (car nhex)) 129 | (ndice (cadr nhex))) 130 | (when (and (not (eq player nplayer)) 131 | (> ndice dice)) 132 | (return t)))))) 133 | 134 | 135 | (defun score-board (board player) 136 | (loop for hex across board 137 | for pos from 0 138 | sum (if (eq (car hex) player) 139 | (if (threatened pos board) 140 | 1 141 | 2) 142 | -1))) 143 | 144 | (defun get-ratings (tree player) 145 | (take-all (lazy-mapcar (lambda (move) 146 | (rate-position (cadr move) player)) 147 | (caddr tree)))) 148 | 149 | (defun rate-position (tree player) 150 | (let ((moves (caddr tree))) 151 | (if (not (lazy-null moves)) 152 | (apply (if (eq (car tree) player) 153 | #'min 154 | #'max) 155 | (get-ratings tree player)) 156 | (get-ratings tree player)) 157 | (score-board (cadr tree) player))) 158 | 159 | ;; The next functions will be just a optimization of AI algorithm 160 | ;; to exclude bad branches on game tree using the Alpha-beta technique 161 | 162 | 163 | (defun ab-rate-position (tree player upper-limit lower-limit) 164 | (let ((moves (caddr tree))) 165 | (if (not (lazy-null moves)) 166 | (if (eq (car tree) player) 167 | (apply #'max (ab-get-ratings-max tree 168 | player 169 | upper-limit 170 | lower-limit)) 171 | (apply #'min (ab-get-ratings-min tree 172 | player 173 | upper-limit 174 | lower-limit))) 175 | (score-board (cadr tree) player)))) 176 | 177 | 178 | (defun ab-get-ratings-max (tree player upper-limit lower-limit) 179 | (labels ((f (moves lower-limit) 180 | (unless (lazy-null moves) 181 | (let ((x (ab-rate-position (cadr (lazy-car moves)) 182 | player 183 | upper-limit 184 | lower-limit))) 185 | (if (>= x upper-limit) 186 | (list x) 187 | (cons x (f (lazy-cdr moves) 188 | (max x lower-limit)))))))) 189 | (f (caddr tree) lower-limit))) 190 | 191 | 192 | (defun ab-get-ratings-min (tree player upper-limit lower-limit) 193 | (labels ((f (moves upper-limit) 194 | (unless (lazy-null moves) 195 | (let ((x (ab-rate-position (cadr (lazy-car moves)) 196 | player 197 | upper-limit 198 | lower-limit))) 199 | (if (<= x lower-limit) 200 | (list x) 201 | (cons x (f (lazy-cdr moves) 202 | (min x upper-limit)))))))) 203 | (f (caddr tree) upper-limit))) 204 | 205 | 206 | (defun handle-computer (tree) 207 | (let ((ratings (ab-get-ratings-max (limit-tree-depth tree *ai-level*) 208 | (car tree) 209 | most-positive-fixnum 210 | most-negative-fixnum))) 211 | (cadr (lazy-nth (position (apply #'max ratings) ratings) (caddr tree))))) 212 | 213 | 214 | (defparameter *board-size* 5) 215 | (defparameter *board-hexnum* (* *board-size* *board-size*)) 216 | -------------------------------------------------------------------------------- /land-of-lisp/cap9-advanced-generic-programming.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; advanced datatypes: 5 | ;; + ARRAY 6 | ;; + HASH-TABLES 7 | ;; + STRINGS 8 | ;; + STRUCTURES 9 | 10 | ;; generic functions: 11 | ;; sequence functions: 12 | ;; + REDUCE 13 | ;; + FIND-IF 14 | ;; + SOME 15 | ;; + EVERY 16 | ;; + POSITION 17 | ;; + COUNT 18 | ;; generic setter: 19 | ;; + SETF 20 | 21 | ;; best way to handle various datatypes: DEFMETHOD 22 | 23 | (defparameter examples nil) 24 | 25 | (defmacro define-example (name &rest body) 26 | `(push (cons (quote ,name) 27 | (apply #'list (quote ,body))) examples)) 28 | 29 | (define-example example-of-arrays 30 | (make-array 3) 31 | ;; => #(0 0 0) 32 | (defparameter x (make-array 3)) 33 | ;; x => #(0 0 0) 34 | (aref x 1) ;; => 0 35 | 36 | ;; the generic setf macro operator 37 | (setf (aref x 1) 'foo) 38 | ;; x => #(0 FOO 0) 39 | ;; combining setf + aref we can set elements on 40 | ;; array positions 41 | 42 | ;; but this can be used in list too! 43 | ;; yes... lists of common lisp is not immutable! 44 | ;; functional programming? forget about that. 45 | 46 | (defparameter foo '(a b c)) 47 | foo 48 | ;; foo => (a b c) 49 | (second foo) 50 | ;; => B 51 | (setf (second foo) 'z) 52 | foo 53 | ;; => (a z c) 54 | 55 | ;; setf is a magic setter. 56 | (defparameter foo (make-array 4)) 57 | foo 58 | ;; => #(0 0 0 0) 59 | 60 | (setf (aref foo 2) '(x y z)) 61 | foo 62 | ;; => #(0 0 (X Y Z) 0) 63 | 64 | (setf (car (aref foo 2)) (make-hash-table)) 65 | ;; hash tables has its own examples in the next section 66 | 67 | (setf (gethash 'zoink (car (aref foo 2))) 5) 68 | foo 69 | ;; => #(0 0 (# Y Z) 0) 70 | ) 71 | 72 | (define-example array-vs-lists 73 | (nth 1 '(foo bar baz)) 74 | ;; access O(n) 75 | 76 | (aref #(foo bar baz) 1) 77 | ;; access O(1) 78 | 79 | ;; tl;dr => array has a better performance than lists 80 | 81 | ) 82 | 83 | 84 | ;; hash tables are like alists (assoc lists) => ((key value) ... ... ... (key-n value-n)) 85 | (define-example example-of-hash-tables 86 | ;; create a new hash table 87 | (make-hash-table) 88 | ;; => # 89 | (defparameter x (make-hash-table)) 90 | (gethash 'yup x) 91 | ;; => NIL, NIL 92 | (setf (gethash 'yup x) '25) 93 | (gethash 'yup x) 94 | ;; => 25, T 95 | 96 | ;; defining drink-order example like alist made before 97 | (defparameter *drink-order* (make-hash-table)) 98 | (setf (gethash 'bill *drink-order*) 'double-espresso) 99 | (setf (gethash 'lisa *drink-order*) 'small-drip-coffee) 100 | (setf (gethash 'john *drink-order*) 'medium-latte) 101 | 102 | ;; accessing the drink order for any person 103 | (gethash 'lisa *drink-order*) 104 | ;; hash table access performance is like array 105 | ;; access/set time -> O(1) 106 | ) 107 | 108 | (define-example returning-multiple-values 109 | (round 2.4) 110 | ;; => 2, 0.4 111 | (defun foo () (values 3 7)) 112 | (foo) 113 | ;; => 3, 7 114 | (+ (foo) 5) 115 | ;; => 8 (ignoring the second value) 116 | 117 | ;; bind multiple values from functions and create 118 | ;; a lexical scope like let 119 | (multiple-value-bind (a b) (foo) 120 | (+ a b)) 121 | ;; => 10 122 | 123 | ;; the usage of multiple-values is supported by CL 124 | ;; but is not so common used on moderns lisp dialects 125 | ;; like clojure 126 | 127 | ;; BTW, Land of Lisp explicitly say that on this book 128 | ;; we don't will see much examples of this. 129 | 130 | ;; I don't have sure if this is really useful. 131 | ;; Maybe passing error state like Go (value error) 132 | ) 133 | 134 | (define-example example-of-structures 135 | (defstruct person 136 | :name 137 | :age 138 | :waist-size 139 | :favorite-color) ;; 4 slots 140 | (defparameter *bob* (make-person :name "Bob" 141 | :age 35 142 | :waist-size 32 143 | :favorite-color "blue")) 144 | *bob* 145 | ;; => #S(PERSON :NAME "Bob" :AGE 35 :WAIST-SIZE 32 :FAVORITE-COLOR "blue") 146 | (person-age *bob*) 147 | ;; => 35 148 | (setf (person-age *bob*) 36) ;; the magic setter macro again 149 | ;; works fine with structures as well 150 | (person-age *bob*) 151 | ;; => 36 152 | 153 | 154 | ;; the problem of lispers and object-oriented programming 155 | ;; let's see a alternative for structures only using lists 156 | (defun make-person. (name age waist-size favorite-color) 157 | (list name age waist-size favorite-color)) 158 | (defun person-age. (person) 159 | (cadr person)) 160 | (defparameter *bob* (make-person. "bob" 35 32 "blue")) 161 | *bob* 162 | (person-age. *bob*) 163 | 164 | ;; but is a bad idea. we'll need all the selectors for person 165 | ;; and the REPL representation is useless. How we can say if 166 | ;; this list define a person. Bob's age is 35 or 32? 167 | ;; Another problem is changing the state... lists don't works well 168 | ;; with it. First: your nature is a bunch of recursive cons cells. 169 | ;; In that example the better approach is defining structures in CL. 170 | 171 | ) 172 | 173 | 174 | (define-example example-handling-data-in-a-generic-way 175 | ;; a great example of generic function 176 | ;; at which can handle various types is the 177 | ;; function length 178 | ;; that type of functions are called of: 179 | ;; "sequence functions" (handle sequences) 180 | (length "blub") 181 | ;; => 4 182 | (length '(a b c)) 183 | ;; => 3 184 | (length (make-array 5)) 185 | ;; => 5 186 | 187 | ;; another great examples for sequence functions 188 | ;; are the specific for search: 189 | ;; find-if, count, position, some and every 190 | 191 | (find-if #'numberp '(a b 5 d)) 192 | ;; => 5 193 | (count #\s "Mississippi") 194 | ;; => 4 195 | (position #\4 "2kewl4skewl") 196 | ;; => 5 197 | (some #'numberp '(a b 5 d)) 198 | ;; => T 199 | (every #'numberp '(a b 5 d)) 200 | ;; => NIL 201 | 202 | ;; another useful generic sequence function: reduce 203 | (reduce #'+ '(3 4 6 5 2)) 204 | ;; => 20 205 | ;; an way to understand the evaluation of reduce is 206 | (reduce #'cons '(1 2 3 4)) 207 | ;; => (((1 . 2) . 3) . 4) 208 | (reduce (lambda (best item) 209 | (if (and (evenp item) 210 | (> item best)) 211 | item 212 | best)) 213 | '(7 4 6 5 2) 214 | :initial-value 0) 215 | ;; => 6 216 | ;; without define the initial-value we got 7 217 | 218 | 219 | (defun sum (sequence) 220 | (reduce #'+ sequence)) 221 | 222 | (sum '(1 2 3)) 223 | (sum #(1 2 3 4 5)) 224 | 225 | (map 'string 226 | (lambda (x) 227 | (if (eq x #\s) 228 | #\S 229 | x)) 230 | "this is a string") 231 | 232 | ;; two more import sequence functions: subseq and 233 | ;; sort 234 | 235 | (subseq "america" 2 6) 236 | ;; => eric 237 | (sort '(5 8 2 4 9 3 6) #'<) 238 | ;; => (2 3 4 5 6 8 9) 239 | 240 | ;; we can create our own generic functions 241 | ;; using typing checking; the most frequently 242 | ;; predicates are: arrayp, characterp, consp, 243 | ;; hash-table-p, listp, stringp, symbolp 244 | 245 | (defun add (a b) 246 | (cond ((and (numberp a) 247 | (numberp b)) 248 | (+ a b)) 249 | ((and (listp a) 250 | (listp b)) 251 | (append a b)))) 252 | 253 | (add 1 2) 254 | ;; => 3 255 | (add '(1 2) '(3 4)) 256 | ;; => (1 2 3 4) 257 | 258 | ;; but we have a better way to do this using 259 | ;; generic methods for multiple types 260 | ;; this is called "type dispatching" 261 | 262 | (defmethod add. ((a number) (b number)) 263 | (+ a b)) 264 | 265 | (defmethod add. ((a list) (b list)) 266 | (append a b)) 267 | 268 | (add. 1 2) 269 | (add. '(a b) '(c d)) 270 | 271 | 272 | ;; the `defmethod` is like `defun` except that it 273 | ;; allows us to write multiple functions with 274 | ;; the same name 275 | 276 | ;; defstruct + defmethod => simple OO system 277 | ) 278 | 279 | 280 | (defun print-example (example) 281 | (let ((name (car example)) 282 | (instrunctions (cdr example))) 283 | (format t ":: ~A ~%" name) 284 | (loop for i in instrunctions do 285 | (format t "> ~a~%~a~%" i (eval i))) 286 | (princ #\newline))) 287 | 288 | (defun run-examples () 289 | (mapcar #'print-example (reverse examples))) 290 | 291 | 292 | ;; the continuation of this chapter is a game called: 293 | ;; ORC BATTLE GAME 294 | ;; I'll write the functions in another file because 295 | ;; this is especial of only REPL examples at which 296 | ;; I use the define-example macro to can be executable 297 | 298 | 299 | (run-examples) 300 | -------------------------------------------------------------------------------- /land-of-lisp/cap9-orc-battle-game.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | #| 6 | 7 | -- ORC BATTLE GAME -- 8 | 9 | In the Orc Battle game, you are a knight surrounded by 12 monsters, engaged 10 | in a fight to the death. With your superior wits and your repertoire 11 | of sword-fighting maneuvers, you must carefully make strategies in your battle with orcs, 12 | hydras, and other nasty enemies. 13 | 14 | c 15 | Using DEFMETHOD and DEFSTRUCT, let's dispatch some whoop ass on these vermin! 16 | 17 | |# 18 | 19 | 20 | ;; global variables for player status 21 | 22 | (defparameter *player-health* nil) 23 | (defparameter *player-agility* nil) 24 | (defparameter *player-strength* nil) 25 | 26 | 27 | ;; we'll store our monsters in an array called *monsters* 28 | ;; we'll also define a list of functions for building monsters that 29 | ;; we'll store in the variable *monster-builders* (AQUI É MONSTRO, PORRA) 30 | 31 | (defparameter *monsters* nil) 32 | (defparameter *monster-builders* nil) 33 | (defparameter *monster-num* 6) ;; high => more difficult 34 | 35 | (defun randval (n) 36 | (1+ (random (max 1 n)))) 37 | 38 | ;; STRUCTS 39 | 40 | ;; THE MONSTERS 41 | 42 | ;; generic monster strict 43 | (defstruct monster (health (randval 10))) 44 | 45 | ;; THE WICKED ORC 46 | (defstruct (orc (:include monster)) 47 | (club-level (randval 8))) 48 | (push #'make-orc *monster-builders*) 49 | 50 | (defmethod monster-show ((m orc)) 51 | (princ "A wicked orc with a level ") 52 | (princ (orc-club-level m)) 53 | (princ " club")) 54 | 55 | (defmethod monster-attack ((m orc)) 56 | (let ((x (randval (orc-club-level m)))) 57 | (princ "An orc swings his club at you knocks off ") 58 | (princ x) 59 | (princ " of your health points. ") 60 | (decf *player-health* x))) 61 | 62 | 63 | ;; THE MALICIOUS HYDRA 64 | (defstruct (hydra (:include monster))) 65 | (push #'make-hydra *monster-builders*) 66 | 67 | (defmethod monster-show ((m hydra)) 68 | (princ "A malicious hydra with ") 69 | (princ (monster-health m)) 70 | (princ " heads. ")) 71 | 72 | (defmethod monster-hit ((m hydra) x) 73 | (decf (monster-health m) x) 74 | (if (monster-dead m) 75 | (princ "The corpse of the fully decapitated hydra falls to the floor! ") 76 | (progn (princ "You lop off ") 77 | (princ x) 78 | (princ " of hydra's heads! ")))) 79 | 80 | (defmethod monster-attack ((m hydra)) 81 | (let ((x (randval (ash (monster-health m) -1)))) 82 | (princ "A hydra attacks you with ") 83 | (princ x) 84 | (princ " of its heads! It also grows back one more head! ") 85 | (incf (monster-health m)) 86 | (decf *player-health* x))) 87 | 88 | (defstruct (slime-mold (:include monster)) 89 | (slimeness (randval 5))) 90 | (push #'make-slime-mold *monster-builders*) 91 | 92 | 93 | (defmethod monster-attack ((m slime-mold)) 94 | (princ "A slime mold of slimness of ") 95 | (princ (slime-mold-slimeness m)) 96 | (princ " attacks ")) 97 | 98 | (defmethod monster-show ((m slime-mold)) 99 | (let ((x (randval (slime-mold-slimeness m)))) 100 | (princ "A slime mold wraps around your legs and decreases your agility by ") 101 | (princ x) 102 | (princ "! ") 103 | (decf *player-agility* x) 104 | (when (zerop (random 2)) 105 | (princ "It also squirts in your face, taking away a health point! ") 106 | (decf *player-health*)))) 107 | 108 | (defstruct (brigand (:include monster))) 109 | (push #'make-brigand *monster-builders*) 110 | 111 | (defmethod monster-attack ((m brigand)) 112 | (let ((x (max *player-health* 113 | *player-agility* 114 | *player-strength*))) 115 | (cond ((= x *player-health*) 116 | (princ "A brigand hits you with his slingshot taking off 2 health points! ") 117 | (decf *player-health* 2)) 118 | ((= x *player-agility*) 119 | (princ "A brigand catches your leg with his whip taking off 2 agility points! ") 120 | (decf *player-agility* 2)) 121 | ((= x *player-strength*) 122 | (princ "A brigand cuts your arm with his whip, taking off 2 strength points! ") 123 | (decf *player-strength* 2))))) 124 | 125 | 126 | (defun monster-dead (m) 127 | (<= (monster-health m) 0)) 128 | 129 | (defun monsters-dead () 130 | (every #'monster-dead *monsters*)) 131 | 132 | (defmethod monster-hit (m x) 133 | (decf (monster-health m) x) 134 | (if (monster-dead m) 135 | (progn (princ "You killed the ") 136 | (princ (type-of m)) 137 | (princ "! ")) 138 | (progn (princ "You hit the ") 139 | (princ (type-of m)) 140 | (princ ", knocking off") 141 | (princ x) 142 | (princ " health points! ")))) 143 | 144 | 145 | 146 | (defmethod monster-show (m) 147 | (princ "A fierce ") 148 | (princ (type-of m))) 149 | 150 | (defmethod monster-attack (m)) 151 | 152 | ;; helper functions for player attack 153 | (defun random-monster () 154 | (let ((m (aref *monsters* (random (length *monsters*))))) 155 | (if (monster-dead m) 156 | (random-monster) 157 | m))) 158 | 159 | (defun pick-monster () 160 | (fresh-line) 161 | (princ "Monster #:") 162 | (fresh-line) 163 | (let ((x (read))) 164 | (if (not (and (integerp x) 165 | (>= x 1) 166 | (<= x *monster-num*))) 167 | (progn (princ "That is not a valid monster number.") 168 | (pick-monster)) 169 | (let ((m (aref *monsters* (1- x)))) 170 | (if (monster-dead m) 171 | (progn (princ "That monster is already dead.") 172 | (pick-monster)) 173 | m))))) 174 | 175 | (defun init-monsters () 176 | (setf *monsters* 177 | (map 'vector 178 | (lambda (x) 179 | (declare (ignore x)) 180 | (funcall (nth (random (length *monster-builders*)) 181 | *monster-builders*))) 182 | (make-array *monster-num*)))) 183 | 184 | (defun show-monsters () 185 | (fresh-line) 186 | (princ "Your foes:") 187 | (let ((x 0)) 188 | (map 'list 189 | (lambda (m) 190 | (fresh-line) 191 | (princ " ") 192 | (princ (incf x)) 193 | (princ ". ") 194 | (if (monster-dead m) 195 | (princ "**dead**") 196 | (progn (princ "(Health=") 197 | (princ (monster-health m)) 198 | (princ ") ") 199 | (monster-show m)))) 200 | *monsters*))) 201 | 202 | (defun init-player() 203 | "Set the initial tributes of our knight" 204 | (setf *player-health* 30) 205 | (setf *player-agility* 30) 206 | (setf *player-strength* 30)) 207 | 208 | (defun player-dead () 209 | "Check if the player is alive" 210 | (<= *player-health* 0)) 211 | 212 | (defun show-player () 213 | "If the player is alive, show in REPL your info at each action" 214 | (fresh-line) 215 | (format t "You are a valiant knight with a health of ~a, an agility of ~a and a strength of ~a" 216 | *player-health* 217 | *player-agility* 218 | *player-health*)) 219 | 220 | (defun player-attack () 221 | "The player-attack function lets us manage a player's attack" 222 | (fresh-line) 223 | (princ "Attack style: [s]tab [d]ouble swing [r]oundhouse: ") 224 | (fresh-line) 225 | (case (read) 226 | (s (monster-hit (pick-monster) 227 | (+ 2 (randval (ash *player-strength* -1))))) 228 | (d (let ((x (randval (truncate (/ *player-strength* 6))))) 229 | (format t "Your double swing has a strength of ~a" x) 230 | (fresh-line) 231 | (monster-hit (pick-monster) x) 232 | (unless (monsters-dead) 233 | (monster-hit (pick-monster) x)))) 234 | (otherwise (dotimes (x (1+ (randval (truncate (/ *player-strength* 3))))) 235 | (unless (monsters-dead) 236 | (monster-hit (random-monster) 1)))))) 237 | 238 | 239 | 240 | (defun game-loop () 241 | "The game-loop function handles the repeated cycles of monster 242 | and player attacks." 243 | (unless (or (player-dead) 244 | (monsters-dead)) 245 | (fresh-line) 246 | (show-player) 247 | (dotimes (k (1+ (truncate (/ (max 0 *player-agility*) 15)))) 248 | (unless (monsters-dead) 249 | (show-monsters) 250 | (player-attack))) 251 | (fresh-line) 252 | (map 'list 253 | (lambda (m) 254 | (or (monster-dead m) 255 | (monster-attack m))) 256 | *monsters*) 257 | (game-loop))) 258 | 259 | ;; the big picture function 260 | (defun orc-battle () 261 | "Main function of the game" 262 | (init-monsters) 263 | (init-player) 264 | (game-loop) 265 | (when (player-dead) 266 | (princ "You have been killed. Game Over.")) 267 | (when (monsters-dead) 268 | (princ "Congratulations! You have vanquished all of your foes."))) 269 | 270 | 271 | 272 | (orc-battle) 273 | ;; just execute this game via terminal as: sbcl --script this-file-name.lisp 274 | -------------------------------------------------------------------------------- /land-of-lisp/cap5-building-a-text-game-engine.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | 5 | ;; node (description) 6 | (defparameter *nodes* '((living-room (you are in the living-room. 7 | a wizard is snoring loudly on the couch.)) 8 | (garden (you are in a beatiful garden. 9 | there is a well in front of you.)) 10 | (attic (you are in the attic. 11 | there os a giant welding torch in the corner.)))) 12 | 13 | 14 | ;; (node (edge direction way)) 15 | (defparameter *edges* '((living-room (garden west door) 16 | (attic upstairs ladder)) 17 | (garden (living-room east door)) 18 | (attic (living-room downstairs ladder)))) 19 | 20 | 21 | ;; set of objects 22 | (defparameter *objects* '(whiskey bucket frog chain shit gold)) 23 | 24 | 25 | ;; (object location) 26 | (defparameter *objects-locations* '((whiskey living-room) 27 | (bucket living-room) 28 | (chain garden) 29 | (frog garden) 30 | (shit attic) 31 | (gold attic))) 32 | 33 | 34 | ;; we can put the itens of inventory at *objects-locations* 35 | ;; but i decide is better use *inventory* to split that 36 | ;; and is more easily to handle on the functions about pickup-drop 37 | (defparameter *inventory* nil) 38 | 39 | 40 | ;; that variable handle the actual location of the player 41 | (defparameter *location* 'living-room) 42 | 43 | 44 | ;; commands whose the user can be type at repl 45 | (defparameter *allowed-commands* '(inventory look walk pickup drop help)) 46 | 47 | ;; a lot of tests for running 48 | ;; on the end of that script 49 | (defparameter *tests* '((describe-path '(garden west door)) 50 | (describe-location 'living-room *nodes*) 51 | (describe-paths 'living-room *edges*) 52 | (objects-at 'living-room *objects* *objects-locations*) 53 | (describe-objects 'living-room *objects* *objects-locations*) 54 | (look) 55 | (pickup 'whiskey) 56 | (inventory) 57 | (look) 58 | (drop 'whiskey) 59 | (inventory) 60 | (look) 61 | (drop 'whiskey) 62 | (inventory) 63 | (look) 64 | (walk 'upstairs) 65 | (pickup 'shit) 66 | (pickup 'gold) 67 | (drop 'shit) 68 | (inventory) 69 | (look))) 70 | 71 | 72 | ;; nice, functional! no side-effections 73 | (defun describe-location (location nodes) 74 | "Sucint description of the localation provide 75 | @location -> symbol 76 | @nodes -> association list" 77 | (cadr (assoc location nodes))) 78 | 79 | 80 | ;; functional! no side-effects 81 | (defun describe-path (edge) 82 | "Sucint description of the path to achieve. 83 | @edge -> (neighbor direction way)" 84 | `(there is a ,(caddr edge) going ,(cadr edge) from here.)) 85 | 86 | 87 | ;; functional! no side-effects 88 | (defun describe-paths (location edges) 89 | "General description of the possible edges on each location 90 | @location -> symbol 91 | @edges -> association list of `(node (neighbor direction way))" 92 | (apply #'append (mapcar #'describe-path (cdr (assoc location edges))))) 93 | 94 | 95 | ;; functional! no side-effects 96 | (defun objects-at (loc objs obj-locs) 97 | "Get the objects inside the location 98 | @loc -> location symbol 99 | @objs -> set of objects 100 | @obj-locs -> the list with (object location)" 101 | (labels ((at-loc-p (obj) 102 | (eq (cadr (assoc obj obj-locs)) loc))) 103 | (remove-if-not #'at-loc-p objs))) 104 | 105 | 106 | ;; functional! no side-effects 107 | (defun describe-objects (loc objs obj-loc) 108 | "Describe the objects existent of the location 109 | @loc -> location symbol 110 | @objs -> set of objects 111 | @obj-locs -> the list with (object location) 112 | 113 | That function is a wrapper of objects-at printing 114 | A beautiful description of object on the location." 115 | (labels ((describe-obj (obj) 116 | `(you see a ,obj on the floor.))) 117 | (apply #'append (mapcar #'describe-obj (objects-at loc objs obj-loc))))) 118 | 119 | 120 | ;; i like that, but is not functional 121 | ;; appears don't have side-effects, we don't have a same 122 | ;; output with the same args, because use global variables 123 | (defun look () 124 | "Look function, do a general descriptions of your location. 125 | The location, the paths and objects." 126 | (append (describe-location *location* *nodes*) 127 | (describe-paths *location* *edges*) 128 | (describe-objects *location* *objects* *objects-locations*))) 129 | 130 | 131 | ;; nice function! but not functional 132 | ;; variable globals: *location* *edges* 133 | ;; side-effect: change *location* 134 | (defun walk (direction) 135 | "Try change the actual location moving to direction and 136 | achieve the next scenario if is possible. 137 | @direction -> a symbol as possible move: 'west, 'east', 'north, 'sul" 138 | (let ((next (find direction 139 | (cdr (assoc *location* *edges*)) 140 | :key #'cadr))) 141 | (if next 142 | (progn (setf *location* (car next)) 143 | (look)) 144 | '(you cannot go that way.)))) 145 | 146 | 147 | ;; variable globals: *objects-locations*, *inventory* 148 | ;; side-effect: change *objects-locations*, *inventory* 149 | (defun pickup (object) 150 | "Try get a object at the current scenarion *location* 151 | Store at *inventory* and remove from *objects-location* 152 | remove from *objects* to... (but i don't like that) 153 | *objects* your purpose is a set of all objects on the game 154 | @object -> a symbol" 155 | (cond ((member object 156 | (objects-at *location* *objects* *objects-locations*)) 157 | (progn (setf *objects-locations* 158 | (remove-if 159 | #'(lambda (x) (eq (car x) object)) 160 | *objects-locations*)) 161 | (push object *inventory*)) 162 | `(you are now carrying the ,object)) 163 | (t '(you cannot get that.)))) 164 | 165 | 166 | ;; variable globals: *objects-locations*, *inventory* 167 | ;; side-effect: change *objects-locations*, *inventory* 168 | (defun drop (object) 169 | "Drop a existent object on the invetory at the actual location 170 | @object -> a symbol" 171 | (if (member object *inventory*) 172 | (progn (push (list object *location*) *objects-locations*) 173 | (setf *inventory* (remove object *inventory*)) 174 | `(you dropped ,object at ,*location*)) 175 | `(you do not have ,object on your inventory))) 176 | 177 | 178 | ;; variable globals: *inventory* 179 | (defun inventory () 180 | "Show the inventory at actual carrying items" 181 | (cons 'items- *inventory*)) 182 | 183 | ;; first version: simple 184 | (defun game-repl-noob () ;; useless 185 | (loop (print (eval (read))))) 186 | 187 | ;; wishful thinking 188 | (defun game-repl () 189 | "The game-repl protecting 190 | the user for black magic of 191 | lisp repl" 192 | (let ((cmd (game-read))) 193 | (unless (eq (car cmd) 'quit) 194 | (game-print (game-eval cmd)) 195 | (game-repl)))) 196 | 197 | ;; now we need define: 198 | ;; game-print, game-read, game-eval 199 | 200 | (defun game-read () 201 | "Read an expressions without () from stdin 202 | and return the expression with (). 203 | Example: walk lest -> (walk 'lest)" 204 | (let ((cmd (read-from-string 205 | (concatenate 'string "(" (read-line) ")")))) 206 | (flet ((quote-it (x) 207 | (list 'quote x))) 208 | (cons (car cmd) (mapcar #'quote-it (cdr cmd)))))) 209 | 210 | (defun game-eval (sexp) 211 | "Eval only commands alloweds" 212 | (if (member (car sexp) *allowed-commands*) 213 | (eval sexp) 214 | '(i do not know that command))) 215 | 216 | ;; i need understand better that black magic below 217 | (defun tweak-text (lst caps lit) 218 | "Make a correct captilize in a list of symbols" 219 | (when lst 220 | (let ((item (car lst)) 221 | (rest (cdr lst))) 222 | (cond ((eq item #\space) (cons item (tweak-text rest caps lit))) 223 | ((member item '(#\! #\? #\.)) (cons item (tweak-text rest t lit))) 224 | ((eq item #\") (tweak-text rest caps (not lit))) 225 | (lit (cons item (tweak-text rest nil lit))) 226 | ((or caps lit) (cons (char-upcase item) (tweak-text rest nil lit))) 227 | (t (cons (char-downcase item) (tweak-text rest nil nil))))))) 228 | 229 | (defun game-print (lst) 230 | (princ (coerce (tweak-text (coerce (string-trim "() " 231 | (prin1-to-string lst)) 232 | 'list) 233 | t 234 | nil) 235 | 'string)) 236 | (fresh-line)) 237 | 238 | ;; no side effect 239 | (defun help () 240 | "Show a descriptions of possible commands to interact 241 | with the lisp world." 242 | '(options -> (look) (walk ?direction) (inventory) (pickup ?object) (drop ?object))) 243 | 244 | (defun eval-printing (command) 245 | "The logic behind the scenes is: 246 | Print the command, so eval the command printed 247 | and print the output" 248 | (print (cons 'command-execute-> `(,command))) 249 | (print (cons 'output-of-command-> (eval command)))) 250 | 251 | (defun run-tests (tests) 252 | (mapcar #'eval-printing tests)) 253 | 254 | (defun simple-test () 255 | (princ (princ 'quit))) 256 | -------------------------------------------------------------------------------- /land-of-lisp/cap8-neowumpus.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | (load "cap7-beyond-basic-lists") ;; load package on namespace :graph-util 5 | 6 | ;; functions: 7 | ;; (graph-util:ugraph->png 'fname 'nodes 'edges) 8 | ;; (graph-util:graph->png 'fname 'nodes 'edges) 9 | 10 | (defparameter *congestion-city-nodes* nil) 11 | (defparameter *congestion-city-edges* nil) 12 | (defparameter *node-num* 30) 13 | (defparameter *edge-num* 45) 14 | (defparameter *worm-num* 3) 15 | (defparameter *cop-odds* 15) 16 | (defparameter *visited-nodes* nil) 17 | (defparameter *player-pos* nil) 18 | 19 | ;; note: make sure that (random n) generates whole numbers in that range 20 | ;; => [0, n) 21 | (defun random-node () 22 | "Return a random number between 1 and *node-num* (30 for default)" 23 | (1+ (random *node-num*))) 24 | 25 | (defun edge-pair (a b) 26 | "Generate a edge pair given a b nodes. Return nil if a e b is equal symbols." 27 | (unless (eql a b) 28 | (list (cons a b) (cons b a)))) 29 | 30 | (defun make-edge-list () 31 | "Generate a list of edges based on random-nodes" 32 | (apply #'append (loop repeat *edge-num* 33 | collect (edge-pair (random-node) 34 | (random-node))))) 35 | 36 | (defun examples-of-loop-macro () 37 | (loop repeat 10 38 | collect 1) 39 | ;; => (1 1 1 1 1 1 1 1 1 1) 40 | (loop for n from 1 to 10 41 | collect n) 42 | ;; => (1 2 3 4 5 6 7 8 9 10) 43 | (loop for n from 1 to 10 44 | collect (+ 100 n)) 45 | ;; => (101 102 103 104 105 106 107 108 109 110) 46 | ) 47 | 48 | ;; connecting isolated non-connected nodes after (make-edge-list) 49 | ;; generation using random 50 | 51 | ;; get the edges connect with node for another node 52 | (defun direct-edges (node edge-list) 53 | (remove-if-not (lambda (x) 54 | (eql (car x) node)) 55 | edge-list)) 56 | 57 | ;; get the possible nodes to visit starting with this node 58 | (defun get-connected (node edge-list) 59 | (let ((visited nil)) 60 | (labels ((traverse (node) 61 | (unless (member node visited) 62 | (push node visited) 63 | ;; mapc is not destructive (didn't modify data of arguments) 64 | (mapc (lambda (edge) ;; mapc is like a for-each, but return the second argument instead nil 65 | (traverse (cdr edge))) 66 | (direct-edges node edge-list))))) 67 | (traverse node)) 68 | visited)) 69 | 70 | ;; find islands~! unconnected nodes on the edges 71 | (defun find-islands (nodes edge-list) 72 | (let ((islands nil)) 73 | (labels ((find-island (nodes) 74 | (let* ((connected (get-connected (car nodes) edge-list)) 75 | (unconnected (set-difference nodes connected))) ;; difference between two lists A - B 76 | (push connected islands) 77 | (when unconnected 78 | (find-island unconnected))))) 79 | (find-island nodes)) 80 | islands)) 81 | 82 | 83 | ;; create edges for isolated group of nodes (islands) 84 | (defun connect-with-bridges (islands) 85 | (when (cdr islands) 86 | (append (edge-pair (caar islands) (caadr islands)) 87 | (connect-with-bridges (cdr islands))))) 88 | 89 | ;; create edges for all isolated group of nodes 90 | (defun connect-all-islands (nodes edge-list) 91 | (append (connect-with-bridges (find-islands nodes edge-list)) 92 | edge-list)) 93 | 94 | 95 | (defun add-cops (edge-alist edges-with-cops) 96 | (mapcar (lambda (x) 97 | (let ((node1 (car x)) 98 | (node1-edges (cdr x))) 99 | (cons node1 100 | (mapcar (lambda (edge) 101 | (let ((node2 (car edge))) 102 | (if (intersection (edge-pair node1 node2) 103 | edges-with-cops 104 | :test #'equal) 105 | (list node2 'cops) 106 | edge))) 107 | node1-edges)))) 108 | edge-alist)) 109 | 110 | (defun edges-to-alist (edge-list) 111 | (mapcar (lambda (node1) 112 | (cons node1 113 | (mapcar (lambda (edge) 114 | (list (cdr edge))) 115 | (remove-duplicates (direct-edges node1 edge-list) 116 | :test #'equal)))) 117 | (remove-duplicates (mapcar #'car edge-list)))) 118 | 119 | 120 | (defun make-city-edges() 121 | (let* ((nodes (loop for i from 1 to *node-num* collect i)) 122 | (edge-list (connect-all-islands nodes (make-edge-list))) 123 | (cops (remove-if-not (lambda (x) 124 | (declare (ignore x)) ;; SBCL stuff, avoid warning 125 | (zerop (random *cop-odds*))) 126 | edge-list))) 127 | (add-cops (edges-to-alist edge-list) cops))) 128 | 129 | ;; selectors 130 | 131 | (defun neighbors (node edge-alist) 132 | (mapcar #'car (cdr (assoc node edge-alist)))) 133 | 134 | (defun within-one (a b edge-alist) 135 | (member b (neighbors a edge-alist))) 136 | 137 | (defun within-two (a b edge-list) 138 | (or (within-one a b edge-list) 139 | (some (lambda (x) 140 | (within-one x b edge-list)) 141 | (neighbors a edge-list)))) 142 | 143 | (defun make-city-nodes (edge-alist) 144 | (let ((wumpus (random-node)) 145 | (glow-worms (loop for i below *worm-num* 146 | collect (random-node)))) 147 | (loop for n from 1 to *node-num* 148 | collect (append (list n) 149 | (cond ((eql n wumpus) '(wumpus)) 150 | ((within-two n wumpus edge-alist) '(blood!))) 151 | (cond ((member n glow-worms) 152 | '(glow-worm)) 153 | ((some (lambda (worm) 154 | (within-one n worm edge-alist)) 155 | glow-worms) 156 | '(lights!))) 157 | (when (some #'cdr (cdr (assoc n edge-alist))) 158 | '(sirens!)))))) 159 | 160 | (defun find-empty-node () 161 | (let ((x (random-node))) 162 | (if (cdr (assoc x *congestion-city-nodes*)) 163 | (find-empty-node) 164 | x))) 165 | 166 | (defun draw-city () 167 | (graph-util:ugraph->png "city" *congestion-city-nodes* *congestion-city-edges*)) 168 | 169 | 170 | ;; BUG FOUND HERE!!! 171 | (defun known-city-nodes () 172 | (mapcar (lambda (node) 173 | (if (member node *visited-nodes*) 174 | (let ((n (assoc node *congestion-city-nodes*))) 175 | (if (eql node *player-pos*) 176 | (append n '(*)) 177 | n)) 178 | (list node '? ))) 179 | (remove-duplicates 180 | (append *visited-nodes* 181 | (mapcan (lambda (node) 182 | (mapcar #'car (cdr (assoc node *congestion-city-edges*)))) 183 | *visited-nodes*))))) 184 | 185 | 186 | (defun known-city-edges () 187 | (mapcar (lambda (node) 188 | (cons node (mapcar (lambda (x) 189 | (if (member (car x) *visited-nodes*) 190 | x 191 | (list (car x)))) 192 | (cdr (assoc node *congestion-city-edges*))))) 193 | *visited-nodes*)) 194 | 195 | (defun example-mapcan-function () 196 | (labels ((ingredients (order) 197 | (mapcan (lambda (burger) 198 | (case burger 199 | (single '(patty)) 200 | (double '(patty patty)) 201 | (double-cheese '(patty patty cheese)))) 202 | order))) 203 | (ingredients '(single double-cheese double)))) 204 | ;; => (PATTY PATTY PATTY CHEESE PATTY PATTY) 205 | 206 | 207 | (defun draw-known-city () 208 | (graph-util:ugraph->png "known-city" (known-city-nodes) (known-city-edges))) 209 | 210 | 211 | (defun new-game () 212 | (setf *congestion-city-edges* (make-city-edges)) 213 | (setf *congestion-city-nodes* (make-city-nodes *congestion-city-edges*)) 214 | (setf *player-pos* (find-empty-node)) 215 | (setf *visited-nodes* (list *player-pos*)) 216 | (draw-city) 217 | (draw-known-city)) 218 | 219 | ;; some bug was tracked here 220 | ;; EDITED: actually is in known-city-nodes 221 | ;; backtrace: handle-new-place -> draw-known-city -> known-city-nodes 222 | (defun handle-new-place (edge pos charging) 223 | (let* ((node (assoc pos *congestion-city-nodes*)) 224 | (has-worm (and (member 'glow-worm node) 225 | (not (member pos *visited-nodes*))))) 226 | (pushnew pos *visited-nodes*) 227 | (setf *player-pos* pos) 228 | (draw-known-city) 229 | (cond ((member 'cops edge) (princ "You ran into the cops. Game Over!")) 230 | ((member 'wumpus node) (if charging 231 | (princ "You found the Wumpus!") 232 | (princ "You ran into the Wumpus"))) 233 | (charging (princ "You wasted your last bullet. Game Over!")) 234 | (has-worm (let ((new-pos (random-node))) 235 | (princ "You ran into a Glow Worm Gang! You're now at ") 236 | (princ new-pos) 237 | (handle-new-place nil new-pos nil)))))) 238 | 239 | (defun handle-direction (pos charging) 240 | (let ((edge (assoc pos 241 | (cdr (assoc *player-pos* *congestion-city-edges*))))) 242 | (if edge 243 | (handle-new-place edge pos charging) 244 | (princ "That location does not exist!")))) 245 | 246 | (defun walk (pos) 247 | (handle-direction pos nil)) 248 | 249 | (defun charge (pos) 250 | (handle-direction pos t)) 251 | 252 | ;; HOW TO PLAY:: 253 | ;; (load "this-file") 254 | ;; (new-game) 255 | ;; => created a file called known-city.png 256 | ;; => so well the, for spoilers, an overall map of the city is created as city.png 257 | ;; open it in a browser, it's our map 258 | ;; use (walk num) & (charge num) to walk and shot between the nodes from edges 259 | ;; at each walk/charge call a new known-city.png is generated (updated) 260 | ;; you have just one shot, so make sure to not waste this bullet 261 | -------------------------------------------------------------------------------- /land-of-lisp/cap4-conditionals.lisp: -------------------------------------------------------------------------------- 1 | ;; 2 | ;; MM""""""""`M 3 | ;; MM mmmmmmmM 4 | ;; M` MMMM 88d8b.d8b. .d8888b. .d8888b. .d8888b. 5 | ;; MM MMMMMMMM 88''88'`88 88' `88 88' `"" Y8ooooo. 6 | ;; MM MMMMMMMM 88 88 88 88. .88 88. ... 88 7 | ;; MM .M dP dP dP `88888P8 '88888P' '88888P' 8 | ;; MMMMMMMMMMMM 9 | ;; 10 | ;; M""MMMMMMMM M""M M""MMMMM""M MM""""""""`M 11 | ;; M MMMMMMMM M M M MMMMM M MM mmmmmmmM 12 | ;; M MMMMMMMM M M M MMMMP M M` MMMM 13 | ;; M MMMMMMMM M M M MMMM' .M MM MMMMMMMM 14 | ;; M MMMMMMMM M M M MMP' .MM MM MMMMMMMM 15 | ;; M M M M M .dMMM MM .M 16 | ;; MMMMMMMMMMM MMMM MMMMMMMMMMM MMMMMMMMMMMM Version 1.0beta27 17 | ;; 18 | ;; http://github.com/overtone/emacs-live 19 | ;; 20 | ;; Hello Manoel, it's lovely to see you again. I do hope that you're 21 | 22 | 23 | ;; if conditions 24 | 25 | ;; returns true 26 | (if '(1) 27 | :true 28 | :false) 29 | 30 | ;; returns true too 31 | (if '() 32 | :false 33 | :true) 34 | 35 | ;; return the length of a list 36 | (defun my-length (list) 37 | "My function personal length. 38 | That is a common docstring in common lisp." 39 | (if list 40 | (1+ (my-length (cdr list))) 41 | 0)) 42 | 43 | (my-length (list 1 2 3 4)) 44 | 45 | ;; the history behind the simmetry of nil and empty lists 46 | (and (equal () nil) (equal '() 'nil)) 47 | ;; the four () disguises 48 | ;; () | nil 49 | ;; '()| 'nil 50 | 51 | ;; the four () disguises 52 | ;; () | nil 53 | ;; '()| 'nil 54 | 55 | ;; 'yup 56 | (if (= (+ 1 2) 3) 57 | 'yup 58 | 'nope) 59 | 60 | ;; 'nope 61 | (if (= (+ 1 2) 4) 62 | 'yupq 63 | 'nope) 64 | 65 | ;; 'the-list-has-stuff-in-it 66 | (if '(1) 67 | 'the-list-has-stuff-in-it 68 | 'the-list-is-empty) 69 | 70 | ;; the-list-is-empty 71 | (if '() 72 | 'the-list-has-stuff-in-it 73 | 'the-list-is-empty) 74 | 75 | (oddp 3) 76 | (evenp 2) 77 | 78 | 79 | (if (oddp 5) 80 | 'odd-number 81 | (/ 1 10)) 82 | 83 | 84 | ;; progn, global variables and the if 'form' (nothing here is statement, all are 'forms') 85 | (defvar *number-was-odd* nil) 86 | 87 | (defun nice-side-effect-lol (x) 88 | "If odd return the symbol correspondent 89 | the side-effect is change the global 90 | variable *number-was-odd*" 91 | (if (oddp x) 92 | (progn (setf *number-was-odd* t) 93 | 'odd-number) 94 | 'even-number)) 95 | 96 | (nice-side-effect-lol 5) *number-was-odd* 97 | 98 | ;; 99 | ;; BASIC IDEAS ABOUT CONDITIONALS 100 | ;; 101 | 102 | (defvar *number-is-odd* nil) 103 | (when (oddp 5) 104 | (setf *number-is-odd* t) 105 | 'odd-number) 106 | 'yup 107 | 'nope) 108 | 109 | (if (= (+ 1 2) 4) 110 | 'yup 111 | 'nope) 112 | 113 | (if '(1) 114 | 'the-list-has-stuff-in-it 115 | 'the-list-is-empty) 116 | 117 | (if '() 118 | 'the-list-has-stuff-in-it 119 | 'the-list-is-empty) 120 | 121 | (if (oddp 5) 122 | 'odd-number 123 | (/ 1 10)) 124 | 125 | 126 | ;; more examples about if form 127 | (defvar *number-was-odd* nil) 128 | 129 | (defun nice-side-effect-lol (x) 130 | (if (oddp x) 131 | (progn (setf *number-was-odd* t) 132 | 'odd-number) 133 | 'even-number)) 134 | 135 | (nice-side-effect-lol 5) 136 | 137 | 138 | ;; 139 | ;; SYMMETRY IF-ELSE: WHEN AND UNLESS 140 | ;; 141 | 142 | 143 | ;; conditiions; 144 | ;; if, when unless command 145 | ;; case, cond or 146 | 147 | ;; if equivalent -> if-else 148 | ;; when -> if block 149 | ;; unless -> if not block 150 | ;; why use when-unless instead if? Because when 151 | ;; don't do nothing in the opposite way 152 | 153 | (defvar *number-is-odd* nil) 154 | (when (oddp 5) 155 | (setf *number-is-odd* t) 156 | 'odd-number) ;; returns odd-number and ste number-is-odd = t 157 | 158 | (unless (oddp 4) 159 | (setf *number-is-odd* nil) 160 | 'even-number) ;; -> even-number set *number-is-odd* = nil 161 | 162 | 163 | ;; 164 | ;; COND AND CASE 165 | ;; 166 | 167 | ;; the command that does it all: cond 168 | ;; the cond form is the classic way 169 | ;; to do branching in lisp 170 | ;; through the liberal use of parentheses, it allow for an implicit progn, 171 | ;; can handle more than one branch, and can even evaluate several conditions 172 | ;; in sucession 173 | ;; many lispers consider the 'cond' is the one true lisp conditional 174 | 175 | (defvar *arch-enemy* nil) 176 | (defun pudding-eater (person) 177 | (cond ((eq person 'henry) (setf *arch-enemy* 'stupid-lisp-alien) 178 | '(curse you lisp alien - you ate my pudding)) 179 | ((eq person 'johnny) (setf *arch-enemy* 'useless-old-johnny) 180 | '(i hope you choked on my pudding johnny ?)) 181 | (t '(why you eat my pudding stranger ?)))) 182 | 183 | 184 | (pudding-eater 'johnny) *arch-enemy* 185 | (pudding-eater 'henery) *arch-enemy* 186 | 187 | ;; as you can see the cond use a body of parentheses conditions to evaluate 188 | ;; a bunch of possible branchs and conditionals 189 | ;; is like of sum of when 190 | ;; now go re-write the pudding-eater function with case! 191 | 192 | 193 | (defun pudding-eater (person) 194 | (case person 195 | ((henry) (setf *arch-enemy* 'stupid-lisp-alien) 196 | '(curse you lisp alien - you ate my pudding)) 197 | ((johnny) (setf *arch-enemy* 'useless-old-johnny) 198 | '(i hope you choked on my pudding johnny ?)) 199 | (otherwise '(why you eat my pudding stranger ?)))) 200 | 201 | ;; as you can se, the cond and case are really similar, but case 202 | ;; differ with one point, doesnt individual form equalities, 203 | ;; you choice the case and compares later in the individual branchs 204 | ;; with it. 205 | 206 | ;; 207 | ;; AND-OR AS IF CONDITIONALS 208 | ;; 209 | 210 | ;; now we think about the obscure use of conditionals using 211 | ;; only booleans expressions like 'and' and 'or'. 212 | 213 | (and (oddp 3) (oddp 5) (oddp 9)) ;=> t 214 | (or (oddp 2) (oddp 0) (oddp 1)) ;=> t 215 | 216 | 217 | ;; if you see that, these operators appears only mathematical boolean operators 218 | ;; and nothing about condinitional evaluation. But we had some interesting thing. 219 | ;; On really, he can be used for conditional behavior! 220 | ;; For instance, here's now a way to set a variable global to t when the number is even. 221 | 222 | (defun crazy-evenp (x) 223 | (let (is-even) 224 | (or (oddp x) (setf is-even t)) ;; HMM, so black magic 225 | is-even)) 226 | 227 | (crazy-evenp 5) ;; -> nil 228 | (crazy-evenp 6) ;; -> T 229 | 230 | 231 | ;; That works because boolean operations are lazy, if doesn't necessary more evaluate the other expressions 232 | ;; so we don't evaluate that! For (crazy-evenp 5) returns nil because (oddp 5) is true, as for 'or' operation 233 | ;; we need only a uniq true value, the (setf is-even t) is not evaluated. We can call that 'shortcut Boolean evaluation' 234 | ;; and lisp use that. 235 | 236 | ;; Considering that the follow expression can be translated: 237 | 238 | (if *file-modified* 239 | (if (ask-user-about-saving) 240 | (save-file))) 241 | 242 | (and *file-modified* (ask-user-about-saving) (save-file)) 243 | 244 | ;; The and evaluate sequencialy the expressions, but for that, 245 | ;; (save-file) needs to returns a t value althoug 246 | ;; that kind of function don't explicit mean that, save-file may return other things. 247 | ;; We have a problem with that and some lispers can be say is not cool. 248 | ;; A third version of that, and a bit more clear, can be: 249 | 250 | (if (and *file-modified* 251 | (ask-user-about-saving)) 252 | (save-file)) 253 | 254 | ;; using functions that return more than just truth value 255 | ;; checking if something inside the list 256 | 257 | (if (member 1 '(4 3 2 1 5)) 258 | 'one-is-in-the-list 259 | 'one-is-not-the-list) ;; -> one-is-in-the-list 260 | 261 | ;; 262 | ;; MEMBER AND FIND-IF 263 | ;; 264 | 265 | ;; nice, the behavior is correct, otherwhise... member have a little non-trivial returns. 266 | ;; what you think member returns? t or nil? No. See: 267 | 268 | (member 1 '(4 3 2 1 5)) ; -> '(1 5) 269 | (member 2 '(4 3 2 1 5)) ; -> '(2 1 5) 270 | (member nil '(4 3 2 1 nil)) ; -> (nil) 271 | 272 | ;; observes... (nil) != nil, '(nil) is a list with contem a nil atom, or empty list. Is like '(()) != '() 273 | 274 | ;; Then 'member' returns nil if not found, right, but if true return more of just 't'. 275 | ;; Return the value found until the tail. Whose really make senses if you remeber the way a list is constructed. 276 | ;; '(4 3 2 1 nil) is equal to (cons 4 (cons 3 (cons 2 (cons 1 (cons nil nil))))) 277 | ;; so if I found 2, is only need return the list itself whose will content the values until the tail. 278 | 279 | ;; If you are asking some about "Why doesn't return the value it found, instead the tail?". Remember the means 280 | ;; of t and nil. T is anything who doesn't is nil. So, check that example: 281 | 282 | (if (member nil '(1 2 3 4 nil)) 283 | 'nil-inside-of-the-list 284 | 'nil-not-found) 285 | ;; if member returns the value found, 'nil' so the if will be false and will return 'nil-not-found' 286 | ;; whose don't make any sense. Instead that, (member nil '(1 2 3 4 nil))-> (nil) 287 | 288 | ;; other functions whose can be beneficit of that kind of result is find-if 289 | ;; (find-if #'lambda list) 290 | (find-if #'oddp '(0 2 3 4 5)) ;-> 3 291 | 292 | ;; whose is something like any() function 293 | 294 | (if (find-if #'oddp '(0 1 2 3 4 5)) 295 | :we-have-an-odd-number 296 | :no-odd-number-found) 297 | 298 | ;; by other hand... if we searching about nil? HMM, think: 299 | 300 | (if (find-if #'null '(1 abacate nil something)) 301 | :we-found-a-nil-value 302 | :no-nil-value-here) ; -> no-nil-value-here 303 | 304 | ;; We have now at disapointment here, because find-if return the first value found 305 | ;; whose is filtered by the function passed. 306 | ;; Unfortunelly, we can't use find-if for if statement in that case. 307 | ;; If find-if was equal to member function maybe will can be. 308 | ;; These kind of small things that make even grown lispers shed had a tear 309 | 310 | 311 | ;; COMPARING STUFF: eq, equal and More... 312 | 313 | ;; We have a lot of comparison functions in common lisp 314 | ;; in which is a kind of thing is not beauty on lisp. 315 | ;; we have, eq, equal, string-equal, equalp, eql... 316 | 317 | ;; Conrad'Rules say: 318 | ;; -> use eq for compare symbols 319 | ;; -> use equal for compare everything else 320 | 321 | ;; eq: symbols 322 | (defparameter *fruit* 'apple) 323 | 324 | (cond ((eq *fruit* 'apple) 'its-an-apple) 325 | (eq *fruit* 'orange) 'its-an-orange) 326 | 327 | ;; equal: anything 328 | 329 | (equal 'banana 'banana) ;; symbols workin, but use eq ever (more fast) 330 | (equal '(1 2 3 4) '(1 2 3 4)) ;; arbitrary lists 331 | (equal '(3 2 1) (cons 3 (cons 2 (cons 1 nil)))) ;; lists constructed in different ways 332 | (equal 4 4) ;. comparison of integers 333 | (equal 4.5 4.5) ;; floats 334 | (equal "abacate" "abacate") ;; strings 335 | (equal #\a #\a) ;; chars 336 | 337 | 338 | ;; eql: symbols, numbers and chars (don't use for strings) 339 | (eql "asdf" "asdf") ; -> nil! 340 | (eql :asdf :asdf) ; -> t 341 | (eql #\n #\n) ; -> t 342 | (eql 4.222225 4.222225) ;-> t 343 | 344 | ;; equalp is like equal but using more abstract comparisons, like 345 | ;; ignoring case for strings and float numbers comparisons 346 | (equalp "MAnoel" "manoel") ;-> t 347 | (equalp 1.0 1) ; -> t 348 | 349 | ;; resume about I wrote in that file 350 | ;; conditionals: if, when, unless, cond, case 351 | ;; black-magic-conditionals: and, or 352 | ;; checkers: member, find-if 353 | ;; comparators: eq, eql, equal, equalp, string-equal, = 354 | -------------------------------------------------------------------------------- /land-of-lisp/cap11-format.lisp: -------------------------------------------------------------------------------- 1 | ;; Common Lisp Script 2 | ;; Manoel Vilela 3 | 4 | ;; :: Anatomy of the format function 5 | (format t "Add onion rings for only ~$ dollars more!" 1.5) 6 | ;; ARCH => (format &rest ) 7 | ;; STDOUT => "Add onion rings for only 1.50 dollars more" 8 | ;; RETURNS => nil 9 | 10 | ;; the destination parameter 11 | ;; nil => don't print anything; just return the value as a string 12 | ;; t => print the value to the console. In this case, the function just returns nil as a value (as in the example above) 13 | ;; stream => write the data to an output stream 14 | 15 | (princ (reverse 16 | (format nil "Add onion rings for only ~$ dollars more" 1.5))) 17 | ;; RETURNS => "erom srallod 05.1 ylno rof sgnir noino ddA" 18 | 19 | ;; :: The control string parameter 20 | 21 | ;; ~$ is a control sequence which indicates a `monetary floating-point` value 22 | ;; NOTE: Every control sequence recognized by the format functions begins with the tilde (~) character. 23 | 24 | ;; control sequences for printing lisp values 25 | 26 | (prin1 "foo") ;; => "FOO" 27 | (princ "foo") ;; => FOO 28 | 29 | ;; prin1 => machine usage 30 | ;; princ => human readable 31 | 32 | ;; A alternative way can be wrote using the format function with ~s and ~a 33 | ;; control sequences. 34 | 35 | (format t "I am printing ~s in the middle of this sentence." "foo") 36 | ;; => I am printing "foo" in the middle of this sentence. 37 | (format t "I am printing ~a in the middle of this sentence." "foo") 38 | ;; => I am printing foo in the middle of this sentence. 39 | 40 | 41 | ;; For example, by writing ~10a in the following example, we add seven spaces 42 | ;; to the right of foo, making the total width of the formatted value 10 chars. 43 | 44 | (format t "I am printing ~10a within ten spaces of room." "foo") 45 | ;; => I am printing foo within ten spaces of room. 46 | 47 | ;; We can also add spaces on the left side of the value by adding the @ symbol. 48 | 49 | (format t "I am printing ~10@a within ten spaces of room." "foo") 50 | ;; => I am printing foo within ten spaces of room. 51 | 52 | ;; control sequences can accept more than just one parameter. 53 | ;; Let's look at an example that sets the second param of the ~a control sequence as well: 54 | 55 | (format t "I am printing ~10,3a within then (or more) spaces of room." "foo") 56 | ;; => I am printing foo within then (or more) spaces of room. 57 | 58 | ;; As you can see, additional parameters to a control sequence are separated 59 | ;; with a comma. In this case, the second parameter is set to 3. Which tells 60 | ;; the format command to add spaces in groups of three until the goal width 61 | ;; of 10 is reached. In this example, a total of nine spaces are added to the 62 | ;; formatted value. This means it overshot our goal width of 10, leading 63 | ;; instead to a total width of 12. But using this feature is rare. 64 | 65 | ;; As well, a control sequence can has a third argument. 66 | 67 | (format t "I am printing ~,,4a in the middle of this sentence." "foo") 68 | ;; => I am printing foo in the middle of this sentence. 69 | 70 | ;; Exactly four spaces is added together with the foo symbol. 71 | 72 | ;; The fourth control sequence parameter specifies which character will be used 73 | ;; for padding. For example, in the following listing, we pad the printed 74 | ;; value with four exclamation points: 75 | 76 | (format t "The word ~,,4,'!a feels very important." "foo") 77 | ;; => The word foo!!!! feels very important. 78 | 79 | ;; We can combine the @ symbol with this example too. 80 | 81 | (format t "The word ~,,4,'!@a feels very important." "foo") 82 | ;; => The word !!!!foo feels very important. 83 | 84 | 85 | ;; :: Control Sequences for Formatting Numbers 86 | 87 | ;; the format command has many options designed specifically for controlling 88 | ;; the appearance of numbers. Let's look at some of the more useful ones. 89 | 90 | ;; -> Control Sequence for Formatting Integers 91 | ;; First, we can use format to display a number using a different base. For 92 | ;; instance we can display a number in hexadecimal (base-16) with the ~x control 93 | ;; sequence 94 | 95 | (format t "The number 1000 in hexadecimal is ~x" 1000) 96 | ;; => The number 1000 in hexadecimal is 3E8 97 | 98 | ;; Similarly, we can display a number in binary (base-2) using the ~b control 99 | ;; sequence 100 | 101 | (format t "The number 1000 in binary is ~b" 1000) 102 | ;; => The number 1000 in binary is 1111101000 103 | 104 | ;; We can even explicitly declare that a value will be displayed as a decimal 105 | ;; (base-10) number, using the ~d control sequence: 106 | (format t "The number 1000 in decimal is ~d" 1000) 107 | ;; => The number 1000 in decimal is 1000 108 | 109 | ;; The difference is that ~d supports special parameters and flags 110 | ;; that are specific to printing decimal numbers. For example, we can 111 | ;; place a colon inside the control sequence to enable commas as 112 | ;; digit group separators. 113 | 114 | (format t "Numbers with commas in them are ~:d times better." 1000000) 115 | ;; => Numbers with commas in them are 1,000,000 times better. 116 | 117 | ;; To control the width of the number, we can set the padding parameter, just 118 | ;; as we did with the ~a and ~s control sequences 119 | 120 | (format t "I am printing ~10d within ten spaces of room" 1000000) 121 | ;; => I am printing 1000000 within ten spaces of room 122 | 123 | ;; To change the character used for padding, pass in the desired character 124 | ;; (in this case, the x character) as the second parameter: 125 | 126 | (format t "I am printing ~10,'xd within ten spaces of room" 1000000) 127 | ;; => I am printing xxx1000000 within ten spaces of room 128 | 129 | 130 | ;; :: Control Sequences for Formatting Floating-Point Numbers 131 | 132 | ;; Floating-point values are handled with the ~f control sequence. 133 | ;; Controlling precision by max width size can be done: 134 | 135 | (format t "PI can be estimated as ~4f" 3.141593) 136 | ;; => PI can be estimated as 3.14 137 | 138 | 139 | ;; The second parameter of the ~f control sequence controls the number 140 | ;; of digits displayed after the decimal point. For example, if we pass 4 as 141 | ;; the second parameter in the preceding example, we get the following output: 142 | 143 | (format t "PI can be estimated as ~,4f" 3.141593) 144 | ;; => PI can be estimated as 3.1416 145 | 146 | ;; The third parameter of the ~f control sequence causes the number to 147 | ;; to be scaled by factors of ten. For example, we can pass 2 as the third parameter, 148 | ;; which we can use to multiply a fraction by 10² to turn it into a percentage 149 | (format t "Percentages are ~,,2f% better than fractions" 0.77) 150 | ;; => Percentages are 77.0% better than fractions 151 | 152 | ;; In addition to ~f, we can use the control sequence ~$, which is used for 153 | ;; formatting currencies 154 | (format t "I wish I had ~$ dollars in my bank account." 1000000.2) 155 | ;; => I wish I had 1000000.20 dollars in my bank account. 156 | 157 | ;; :: Printing Multiple Lines of Output 158 | 159 | ;; Common Lisp has two different commands for starting a new line during priting. 160 | ;; The first: terpri 161 | ;; Simply tells LISP to terminate the current line and start a new one for printing 162 | ;; subsequent output. For example, we can print two numbers on different lines like so. 163 | 164 | (progn (princ 22) 165 | (terpri) 166 | (princ 33)) 167 | 168 | ;; STDOUT => 22 169 | ;; 33 170 | 171 | ;; We can also start a new line with fresh-line. This command will start a new line, 172 | ;; but only if the cursor position in the REPL isn't already at the very front of a line. 173 | ;; This is seems be tricky, so let's look at some examples: 174 | 175 | (progn (princ 22) 176 | (fresh-line) 177 | (princ 33)) 178 | 179 | (progn (princ 22) 180 | (fresh-line) 181 | (fresh-line) 182 | (princ 33)) 183 | 184 | ;; The above programs has the same output: 185 | ;; STDOUT => 22 186 | ;; 33 187 | ;; In another words, terpri always print a new line; fresh-line only prints when is needed. 188 | 189 | 190 | ;; The format command has two control sequences equivalents to terpri and fresh-line 191 | ;; NOTE: WHAT THE FUCK!? WHY TERPRI AS NAME OF THIS TYPE OF FUNCTION? IS SO NON-SENSE. 192 | 193 | ;; ~% causes a new line to be created in all cases (like terpri) 194 | ;; ~& creates new lines only as needed (like fresh-line) 195 | 196 | ;; These examples illustrate this difference: 197 | 198 | (progn (format t "this is on one line ~%") 199 | (format t "~%this is on another line")) 200 | ;; STDOUT => 201 | ;; this is on one line 202 | ;; 203 | ;; this is on another line 204 | 205 | (progn (format t "this is on one line ~&") 206 | (format t "~&this is on another line")) 207 | ;; STDOUT => 208 | ;; this is on one line 209 | ;; this is on another line 210 | 211 | ;; As you can see, using an extra ~% prints an unsightly empty line and 212 | ;; using ~& in the same places does not. 213 | 214 | ;; These two line-termination sequences can also have an additional parameter 215 | ;; in front of them to indicate the number of new lines to be created. This is 216 | ;; useful in cases where we want to use empty lines to space out our output. 217 | ;; For example, the addition of 5 in the following examples adds five empty lines 218 | ;; to our output: 219 | 220 | (format t "this will print ~5% two lines spread far apart") 221 | ;; STDOUT => 222 | ;; this will print 223 | ;; 224 | ;; 225 | ;; 226 | ;; 227 | ;; two lines spread far apart 228 | 229 | 230 | ;; :: Justifying Output 231 | 232 | (defun random-animal () 233 | (nth (random 5) 234 | '("dog" "tick" "tiger" "walrus" "kangaroo"))) 235 | 236 | ;; now suppose we want to display a bunch of random animals in a table. 237 | ;; We can do this by using the ~t control sequence. ~t can take a parameter 238 | ;; that specifies the column position at which the formatted value should appear. 239 | ;; For example, to have our table of animals appear in three columns at the fifth, 240 | ;; fifteenth and twenty-fifth character positions, we could create this table 241 | 242 | (loop repeat 10 243 | do (format t "~5t~a ~15t~a ~25t~a~%" 244 | (random-animal) 245 | (random-animal) 246 | (random-animal))) 247 | 248 | ;; STDOUT => 249 | ;; dog tick walrus 250 | ;; kangaroo tiger walrus 251 | ;; dog dog dog 252 | ;; tick tick tiger 253 | ;; walrus kangaroo dog 254 | ;; walrus dog tick 255 | ;; dog kangaroo dog 256 | ;; dog walrus tiger 257 | ;; kangaroo walrus walrus 258 | ;; walrus tick tick 259 | 260 | 261 | ;; Now suppose we want all the animals be spaced equally apart on a single line. 262 | ;; To do so, we can use the ~< and ~> control sequences, as follows: 263 | 264 | (loop repeat 10 265 | do (format t "~30<~a~;~a~;~a~>~%" 266 | (random-animal) 267 | (random-animal) 268 | (random-animal))) 269 | ;; STDOUT => 270 | ;; tick tiger kangaroo 271 | ;; kangaroo walrus tiger 272 | ;; tiger kangaroo tiger 273 | ;; tiger kangaroo tiger 274 | ;; walrus tiger tick 275 | ;; kangaroo tick tiger 276 | ;; tiger walrus tiger 277 | ;; dog walrus tick 278 | ;; tiger tick dog 279 | ;; dog dog kangaroo 280 | 281 | 282 | ;; VERY VERY TRICKY 283 | ;; ~< and ~> is used to start and finish a text justifying operation 284 | 285 | ;; For example, we can create a single, neatly centered column as follows: 286 | 287 | (loop repeat 10 288 | do (format t "~30:@<~a~>~%" (random-animal))) 289 | 290 | 291 | ;; In the same way we can use :@ with multiple justified values, centering 292 | ;; them on the line with additional space at their left and right ends. 293 | 294 | (loop repeat 10 295 | do (format t "~30:@<~a~;~a~;~a~>~%" 296 | (random-animal) 297 | (random-animal) 298 | (random-animal))) 299 | 300 | ;; To produce neat collums, we'll still use the :@ flag, but we'll describe 301 | ;; our rows using three separate 10-character justification sections 302 | 303 | (loop repeat 10 304 | do (format t "~10:@<~a~>~10:@<~a~>~10:@<~a~>~%" 305 | (random-animal) 306 | (random-animal) 307 | (random-animal))) 308 | 309 | ;; STDOUT => 310 | ;; kangaroo walrus dog 311 | ;; kangaroo walrus kangaroo 312 | ;; tiger dog dog 313 | ;; kangaroo tiger dog 314 | ;; dog tick tiger 315 | ;; walrus tiger tiger 316 | ;; walrus dog dog 317 | ;; kangaroo walrus dog 318 | ;; walrus tick tick 319 | ;; tiger tick walrus 320 | 321 | 322 | ;; :: Iterating Through Lists Using Control Sequences 323 | 324 | ;; Format can loop through data using the ~{ and ~} control sequences 325 | 326 | (defparameter *animals* (loop repeat 10 collect (random-animal))) 327 | 328 | (format t "~{I see a ~a! ~}" *animals*) 329 | ;; STDOUT => I see a tick! I see a dog! I see a dog! I see a kangaroo! I see a tick! I see a dog! I see a walrus! I see a tick! I see a dog! I see a walrus! 330 | 331 | ;; To produce this loop, we simply pass the single variable *animals*, a list of items, 332 | ;; to the format function. The control string iterates through the list, constructing 333 | ;; the sentence "I see a ~a" for each member of *animals*. 334 | 335 | ;; A single iteration construct can also grab more than one item from the list, 336 | ;; as in this example: 337 | 338 | (format t "~{I see a ~a... or was it a ~a?~%~}" *animals*) 339 | ;; STDOUT => 340 | #| 341 | I see a tick... or was it a dog? 342 | I see a dog... or was it a kangaroo? 343 | I see a tick... or was it a dog? 344 | I see a walrus... or was it a tick? 345 | I see a dog... or was it a walrus? 346 | |# 347 | 348 | ;; We need be careful in this example above. If the number of elements is odd this 349 | ;; will cause a failure because the data is accessed by pairs. 350 | 351 | ;; :: A Crazy Formatting Trick for Creating Pretty Tables of Data 352 | 353 | (format t "|~{~<|~%|~,33:;~2d ~>~}|" (loop for x below 100 collect x)) 354 | ;; STDOUT => 355 | ;; | 0 1 2 3 4 5 6 7 8 9 | 356 | ;; |10 11 12 13 14 15 16 17 18 19 | 357 | ;; |20 21 22 23 24 25 26 27 28 29 | 358 | ;; |30 31 32 33 34 35 36 37 38 39 | 359 | ;; |40 41 42 43 44 45 46 47 48 49 | 360 | ;; |50 51 52 53 54 55 56 57 58 59 | 361 | ;; |60 61 62 63 64 65 66 67 68 69 | 362 | ;; |70 71 72 73 74 75 76 77 78 79 | 363 | ;; |80 81 82 83 84 85 86 87 88 89 | 364 | ;; |90 91 92 93 94 95 96 97 98 99 | 365 | 366 | ;; NEAT! 367 | --------------------------------------------------------------------------------