├── README.md ├── book-examples ├── omega2.l ├── omega2vb.l ├── omega.l ├── godel.l ├── fixedpoint.l ├── lemma.l ├── turing.l ├── omega2.r ├── omega2vb.r ├── omega.r ├── utm.l ├── martin-lof.l ├── fixedpoint.r ├── lemma.r ├── turing.r ├── godel.r ├── exec.l ├── xgodel2.l ├── sets.l ├── xomega3.l ├── decomp.l ├── martin-lof.r ├── occam.l ├── utm.r ├── chaitin2.l ├── exec.r ├── chaitin.l ├── xgodel3.l ├── martin-lof2.l ├── utm2.l ├── chaitin2.r ├── sets.r ├── examples.l ├── kraft.l ├── occam.r ├── decomp.r ├── utm2.r ├── solovay.l ├── martin-lof2.r ├── kraft.r ├── chaitin.r ├── solovay.r └── examples.r ├── .gitignore ├── LICENSE └── chaitin.js /README.md: -------------------------------------------------------------------------------- 1 | chaitin-lisp 2 | ============ 3 | 4 | Toying with a port of Chaitin's LISP 5 | -------------------------------------------------------------------------------- /book-examples/omega2.l: -------------------------------------------------------------------------------- 1 | [[[[ Omega in the limit from below! ]]]] 2 | 3 | define (count-halt prefix bits-left-to-extend) 4 | if = bits-left-to-extend 0 5 | if = success car try t 'eval read-exp prefix 6 | 1 0 7 | + (count-halt append prefix '(0) - bits-left-to-extend 1) 8 | (count-halt append prefix '(1) - bits-left-to-extend 1) 9 | define (omega t) cons (count-halt nil t) 10 | cons / 11 | cons ^ 2 t 12 | nil 13 | (omega 0) 14 | (omega 1) 15 | (omega 2) 16 | (omega 3) 17 | (omega 8) 18 | -------------------------------------------------------------------------------- /book-examples/omega2vb.l: -------------------------------------------------------------------------------- 1 | [[[[ Omega in the limit from below! ]]]] 2 | 3 | define (count-halt prefix bits-left-to-extend) 4 | let x try t 'eval read-exp prefix 5 | if = success car x ^ 2 bits-left-to-extend 6 | if = out-of-time cadr x 0 7 | if = bits-left-to-extend 0 0 8 | + (count-halt append prefix '(0) - bits-left-to-extend 1) 9 | (count-halt append prefix '(1) - bits-left-to-extend 1) 10 | define (omega t) cons (count-halt nil t) 11 | cons / 12 | cons ^ 2 t 13 | nil 14 | (omega 0) 15 | (omega 1) 16 | (omega 2) 17 | (omega 3) 18 | (omega 8) 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Logs 2 | logs 3 | *.log 4 | 5 | # Runtime data 6 | pids 7 | *.pid 8 | *.seed 9 | 10 | # Directory for instrumented libs generated by jscoverage/JSCover 11 | lib-cov 12 | 13 | # Coverage directory used by tools like istanbul 14 | coverage 15 | 16 | # Grunt intermediate storage (http://gruntjs.com/creating-plugins#storing-task-files) 17 | .grunt 18 | 19 | # Compiled binary addons (http://nodejs.org/api/addons.html) 20 | build/Release 21 | 22 | # Dependency directory 23 | # Deployed apps should consider commenting this line out: 24 | # see https://npmjs.org/doc/faq.html#Should-I-check-my-node_modules-folder-into-git 25 | node_modules 26 | 27 | java 28 | -------------------------------------------------------------------------------- /book-examples/omega.l: -------------------------------------------------------------------------------- 1 | [[[[ Omega in the limit from below! ]]]] 2 | 3 | define (all-bit-strings-of-size k) 4 | if = 0 k '(()) 5 | (extend-by-one-bit (all-bit-strings-of-size - k 1)) 6 | define (extend-by-one-bit x) 7 | if atom x nil 8 | cons append car x '(0) 9 | cons append car x '(1) 10 | (extend-by-one-bit cdr x) 11 | define (count-halt p) 12 | if atom p 0 13 | + 14 | if = success car try t 'eval read-exp car p 15 | 1 0 16 | (count-halt cdr p) 17 | define (omega t) cons (count-halt (all-bit-strings-of-size t)) 18 | cons / 19 | cons ^ 2 t 20 | nil 21 | (omega 0) 22 | (omega 1) 23 | (omega 2) 24 | (omega 3) 25 | (omega 8) 26 | -------------------------------------------------------------------------------- /book-examples/godel.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | 3 | A LISP expression that asserts that it itself is unprovable! 4 | 5 | Let g(x): x -> (is-unprovable (value-of (('x)('x)))) 6 | 7 | Then (is-unprovable (value-of (('g)('g)))) 8 | asserts that it itself is not a theorem! 9 | 10 | ]]]]] 11 | 12 | define (g x) 13 | let (L x y) cons x cons y nil [Makes x and y into list.] 14 | (L is-unprovable (L value-of (L (L "' x) (L "' x)))) 15 | 16 | [Here we try g:] 17 | 18 | (g x) 19 | 20 | [ 21 | Here we calculate the LISP expression 22 | that asserts its own unprovability: 23 | ] 24 | 25 | (g g) 26 | 27 | [Here we extract the part that it uses to name itself:] 28 | 29 | cadr cadr (g g) 30 | 31 | [Here we evaluate the name to get back the entire expression:] 32 | 33 | eval cadr cadr (g g) 34 | 35 | [Here we check that it worked:] 36 | 37 | = (g g) eval cadr cadr (g g) 38 | -------------------------------------------------------------------------------- /book-examples/fixedpoint.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | 3 | A LISP expression that evaluates to itself! 4 | 5 | Let f(x): x -> (('x)('x)) 6 | 7 | Then (('f)('f)) is a fixed point. 8 | 9 | ]]]]] 10 | 11 | [Here is the fixed point done by hand:] 12 | 13 | ( 14 | 'lambda(x) cons cons "' cons x nil 15 | cons cons "' cons x nil 16 | nil 17 | 18 | 'lambda(x) cons cons "' cons x nil 19 | cons cons "' cons x nil 20 | nil 21 | ) 22 | 23 | [Now let's construct the fixed point.] 24 | 25 | define (f x) let y [be] cons "' cons x nil [y is ('x) ] 26 | [return] cons y cons y nil [return (('x)('x))] 27 | 28 | [Here we try f:] 29 | 30 | (f x) 31 | 32 | [Here we use f to calculate the fixed point:] 33 | 34 | (f f) 35 | 36 | [Here we find the value of the fixed point:] 37 | 38 | eval (f f) 39 | 40 | [Here we check that it's a fixed point:] 41 | 42 | = (f f) eval (f f) 43 | 44 | [Just for emphasis:] 45 | 46 | = (f f) eval eval eval eval eval eval (f f) 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Robin Berjon 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. -------------------------------------------------------------------------------- /book-examples/lemma.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Lemma for 3 | H(y|x) <= H(x,y) - H(x) + c 4 | 5 | We show that 6 | H(x) <= -log_2 Sum_y P((x y)) + c 7 | 8 | Proof: From U construct U' such that 9 | if U(p) = (x y), then U'(p) = x. 10 | 11 | Then apply the previous chapter to get 12 | H(x) <= -log_2 P'(x) + c 13 | <= -log_2 Sum_y P((x y)) + c 14 | ]]]]] 15 | 16 | define U-prime 17 | 18 | let (is-pair? x) 19 | if atom x false 20 | if atom cdr x false 21 | if atom cdr cdr x true 22 | false 23 | 24 | [run original program for U] 25 | 26 | let v eval read-exp 27 | 28 | [and if is a pair, return first element] 29 | 30 | if (is-pair? v) car v 31 | 32 | [otherwise loop forever] 33 | 34 | let (loop) [be] (loop) [in] 35 | (loop) 36 | 37 | [Test it!] 38 | 39 | run-utm-on bits' xyz 40 | run-utm-on bits' cons a nil 41 | run-utm-on bits' cons a cons b nil 42 | run-utm-on bits' cons a cons b cons c nil 43 | 44 | cadr try 99 U-prime bits' xyz 45 | cadr try 99 U-prime bits' cons a nil 46 | cadr try 99 U-prime bits' cons a cons b nil 47 | cadr try 99 U-prime bits' cons a cons b cons c nil 48 | -------------------------------------------------------------------------------- /book-examples/turing.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | 3 | Proof that the halting problem is unsolvable by using 4 | it to construct a LISP expression that halts iff it doesn't. 5 | 6 | ]]]]] 7 | 8 | define (turing x) 9 | [Insert supposed halting algorithm here.] 10 | let (halts? S-exp) false [<=============] 11 | [Form ('x)] 12 | let y [be] cons "' cons x nil [in] 13 | [Form (('x)('x))] 14 | let z [be] display cons y cons y nil [in] 15 | [If (('x)('x)) has a value, then loop forever, otherwise halt] 16 | if (halts? z) [then] eval z [loop forever] 17 | [else] nil [halt] 18 | 19 | [ 20 | (turing turing) decides whether it itself has a value, 21 | then does the opposite! 22 | 23 | Here we suppose it doesn't have a value, 24 | so it turns out that it does: 25 | ] 26 | 27 | (turing turing) 28 | 29 | define (turing x) 30 | [Insert supposed halting algorithm here.] 31 | let (halts? S-exp) true [<==============] 32 | [Form ('x)] 33 | let y [be] cons "' cons x nil [in] 34 | [Form (('x)('x))] 35 | let z [be] [[[[display]]]] cons y cons y nil [in] 36 | [If (('x)('x)) has a value, then loop forever, otherwise halt] 37 | if (halts? z) [then] eval z [loop forever] 38 | [else] nil [halt] 39 | 40 | [ 41 | And here we suppose it does have a value, 42 | so it turns out that it doesn't. 43 | 44 | It loops forever evaluating itself again and again! 45 | ] 46 | 47 | (turing turing) 48 | -------------------------------------------------------------------------------- /book-examples/omega2.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[ Omega in the limit from below! ]]]] 4 | 5 | define (count-halt prefix bits-left-to-extend) 6 | if = bits-left-to-extend 0 7 | if = success car try t 'eval read-exp prefix 8 | 1 0 9 | + (count-halt append prefix '(0) - bits-left-to-extend 1) 10 | (count-halt append prefix '(1) - bits-left-to-extend 1) 11 | 12 | define count-halt 13 | value (lambda (prefix bits-left-to-extend) (if (= bits-l 14 | eft-to-extend 0) (if (= success (car (try t (' (ev 15 | al (read-exp))) prefix))) 1 0) (+ (count-halt (app 16 | end prefix (' (0))) (- bits-left-to-extend 1)) (co 17 | unt-halt (append prefix (' (1))) (- bits-left-to-e 18 | xtend 1))))) 19 | 20 | define (omega t) cons (count-halt nil t) 21 | cons / 22 | cons ^ 2 t 23 | nil 24 | 25 | define omega 26 | value (lambda (t) (cons (count-halt nil t) (cons / (cons 27 | (^ 2 t) nil)))) 28 | 29 | (omega 0) 30 | 31 | expression (omega 0) 32 | value (0 / 1) 33 | 34 | (omega 1) 35 | 36 | expression (omega 1) 37 | value (0 / 2) 38 | 39 | (omega 2) 40 | 41 | expression (omega 2) 42 | value (0 / 4) 43 | 44 | (omega 3) 45 | 46 | expression (omega 3) 47 | value (0 / 8) 48 | 49 | (omega 8) 50 | 51 | expression (omega 8) 52 | value (1 / 256) 53 | 54 | End of LISP Run 55 | 56 | Elapsed time is 1 seconds. 57 | -------------------------------------------------------------------------------- /book-examples/omega2vb.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[ Omega in the limit from below! ]]]] 4 | 5 | define (count-halt prefix bits-left-to-extend) 6 | let x try t 'eval read-exp prefix 7 | if = success car x ^ 2 bits-left-to-extend 8 | if = out-of-time cadr x 0 9 | if = bits-left-to-extend 0 0 10 | + (count-halt append prefix '(0) - bits-left-to-extend 1) 11 | (count-halt append prefix '(1) - bits-left-to-extend 1) 12 | 13 | define count-halt 14 | value (lambda (prefix bits-left-to-extend) ((' (lambda ( 15 | x) (if (= success (car x)) (^ 2 bits-left-to-exten 16 | d) (if (= out-of-time (car (cdr x))) 0 (if (= bits 17 | -left-to-extend 0) 0 (+ (count-halt (append prefix 18 | (' (0))) (- bits-left-to-extend 1)) (count-halt ( 19 | append prefix (' (1))) (- bits-left-to-extend 1))) 20 | ))))) (try t (' (eval (read-exp))) prefix))) 21 | 22 | define (omega t) cons (count-halt nil t) 23 | cons / 24 | cons ^ 2 t 25 | nil 26 | 27 | define omega 28 | value (lambda (t) (cons (count-halt nil t) (cons / (cons 29 | (^ 2 t) nil)))) 30 | 31 | (omega 0) 32 | 33 | expression (omega 0) 34 | value (0 / 1) 35 | 36 | (omega 1) 37 | 38 | expression (omega 1) 39 | value (0 / 2) 40 | 41 | (omega 2) 42 | 43 | expression (omega 2) 44 | value (0 / 4) 45 | 46 | (omega 3) 47 | 48 | expression (omega 3) 49 | value (0 / 8) 50 | 51 | (omega 8) 52 | 53 | expression (omega 8) 54 | value (1 / 256) 55 | 56 | End of LISP Run 57 | 58 | Elapsed time is 0 seconds. 59 | -------------------------------------------------------------------------------- /book-examples/omega.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[ Omega in the limit from below! ]]]] 4 | 5 | define (all-bit-strings-of-size k) 6 | if = 0 k '(()) 7 | (extend-by-one-bit (all-bit-strings-of-size - k 1)) 8 | 9 | define all-bit-strings-of-size 10 | value (lambda (k) (if (= 0 k) (' (())) (extend-by-one-bi 11 | t (all-bit-strings-of-size (- k 1))))) 12 | 13 | define (extend-by-one-bit x) 14 | if atom x nil 15 | cons append car x '(0) 16 | cons append car x '(1) 17 | (extend-by-one-bit cdr x) 18 | 19 | define extend-by-one-bit 20 | value (lambda (x) (if (atom x) nil (cons (append (car x) 21 | (' (0))) (cons (append (car x) (' (1))) (extend-b 22 | y-one-bit (cdr x)))))) 23 | 24 | define (count-halt p) 25 | if atom p 0 26 | + 27 | if = success car try t 'eval read-exp car p 28 | 1 0 29 | (count-halt cdr p) 30 | 31 | define count-halt 32 | value (lambda (p) (if (atom p) 0 (+ (if (= success (car 33 | (try t (' (eval (read-exp))) (car p)))) 1 0) (coun 34 | t-halt (cdr p))))) 35 | 36 | define (omega t) cons (count-halt (all-bit-strings-of-size t)) 37 | cons / 38 | cons ^ 2 t 39 | nil 40 | 41 | define omega 42 | value (lambda (t) (cons (count-halt (all-bit-strings-of- 43 | size t)) (cons / (cons (^ 2 t) nil)))) 44 | 45 | (omega 0) 46 | 47 | expression (omega 0) 48 | value (0 / 1) 49 | 50 | (omega 1) 51 | 52 | expression (omega 1) 53 | value (0 / 2) 54 | 55 | (omega 2) 56 | 57 | expression (omega 2) 58 | value (0 / 4) 59 | 60 | (omega 3) 61 | 62 | expression (omega 3) 63 | value (0 / 8) 64 | 65 | (omega 8) 66 | 67 | expression (omega 8) 68 | value (1 / 256) 69 | 70 | End of LISP Run 71 | 72 | Elapsed time is 0 seconds. 73 | -------------------------------------------------------------------------------- /book-examples/utm.l: -------------------------------------------------------------------------------- 1 | [[[ 2 | First steps with my new construction for 3 | a self-delimiting universal Turing machine. 4 | We show that 5 | H(x,y) <= H(x) + H(y) + c 6 | and determine c. 7 | Consider a bit string x of length |x|. 8 | We also show that 9 | H(x) <= 2|x| + c 10 | and that 11 | H(x) <= |x| + H(the binary string for |x|) + c 12 | and determine both these c's. 13 | ]]] 14 | 15 | [ 16 | Here is the self-delimiting universal Turing machine! 17 | ] 18 | define (U p) cadr try no-time-limit 'eval read-exp p 19 | (U bits 'cons x cons y cons z nil) 20 | (U append bits 'cons a debug read-exp 21 | bits '(b c d) 22 | ) 23 | [ 24 | The length of alpha in bits is the 25 | constant c in H(x) <= 2|x| + 2 + c. 26 | ] 27 | define alpha 28 | let (loop) let x read-bit 29 | let y read-bit 30 | if = x y 31 | cons x (loop) 32 | nil 33 | (loop) 34 | length bits alpha 35 | (U 36 | append 37 | bits alpha 38 | '(0 0 1 1 0 0 1 1 0 1) 39 | ) 40 | (U 41 | append 42 | bits alpha 43 | '(0 0 1 1 0 0 1 1 0 0) 44 | ) 45 | [ 46 | The length of beta in bits is the 47 | constant c in H(x,y) <= H(x) + H(y) + c. 48 | ] 49 | define beta 50 | cons eval read-exp 51 | cons eval read-exp 52 | nil 53 | length bits beta 54 | (U 55 | append 56 | bits beta 57 | append 58 | bits 'cons a cons b cons c nil 59 | bits 'cons x cons y cons z nil 60 | ) 61 | (U 62 | append 63 | bits beta 64 | append 65 | append bits alpha '(0 0 1 1 0 0 1 1 0 1) 66 | append bits alpha '(1 1 0 0 1 1 0 0 1 0) 67 | ) 68 | [ 69 | The length of gamma in bits is the 70 | constant c in H(x) <= |x| + H(|x|) + c 71 | ] 72 | define gamma 73 | let (loop k) 74 | if = 0 k nil 75 | cons read-bit (loop - k 1) 76 | (loop base2-to-10 eval read-exp) 77 | length bits gamma 78 | (U 79 | append 80 | bits gamma 81 | append 82 | [Arbitrary program for U to compute number of bits] 83 | bits' '(1 0 0 0) 84 | [That many bits of data] 85 | '(0 0 0 0 0 0 0 1) 86 | ) 87 | -------------------------------------------------------------------------------- /book-examples/martin-lof.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Martin-Lof random 3 | iff it is Chaitin random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [First part: not M-L random ===> not Ch random] 16 | 17 | [We create the following set of requirements] 18 | [(output, size-of-program)] 19 | [ (s, |s|-n) : s in A_{n^2}, n >= 2 ] 20 | 21 | [Stage k>=0, look at all A_{n^2} n = 2 to 2+k for time k.] 22 | [Then have to combine stage 0, stage 1,...] 23 | [and eliminate duplicates] 24 | 25 | [infinite computation that displays strings] 26 | [in cover A_m with measure mu <= 1/2^m] 27 | define (A m) 28 | cdr cons 29 | [test case, A_m = string of m 1's] 30 | display base10-to-2 - ^ 2 m 1 31 | nil 32 | 33 | define (is-in? x l) [is x in the list l?] 34 | if atom l false 35 | if = x car l true 36 | (is-in? x cdr l) 37 | 38 | define (convert-to-requirements cover n) [display requirements] 39 | if atom cover requirements [finished?] 40 | let s car cover [get first string] 41 | let cover cdr cover [get rest of strings] 42 | let requirement 43 | cons s cons - length s n nil [form (s, |s|-n)] 44 | if (is-in? requirement requirements) [duplicate?] 45 | [yes] (convert-to-requirements cover n) 46 | [no] let requirements cons display requirement requirements 47 | (convert-to-requirements cover n) 48 | 49 | define (stage k) 50 | if = k 4 stop! [[[stop infinite computation!!!]]] 51 | let (loop i) [i = 0 to k] 52 | if > i k (stage + k 1) [go to next stage] 53 | let n + 2 i [n = 2 + i] 54 | let expr cons cons "' cons A nil 55 | cons * n n nil 56 | let cover caddr try k expr nil [caddr = displays] 57 | let requirements (convert-to-requirements cover n) 58 | (loop + i 1) [bump i] 59 | [initialize i] 60 | (loop 0) 61 | 62 | [to remove duplicates] 63 | define requirements () 64 | 65 | [run it] 66 | (stage 0) 67 | -------------------------------------------------------------------------------- /chaitin.js: -------------------------------------------------------------------------------- 1 | 2 | (function (global) { 3 | // S-expressions 4 | function Sexp () { 5 | this.hd = null; 6 | this.tl = null; 7 | this.at = false; 8 | this.nmb = false; 9 | this.err = false; 10 | this.pname = null; 11 | this.nval = null; 12 | this.vstk = null; 13 | this.str = null; 14 | } 15 | Sexp.createFromSexp = function (h, t) { 16 | var sexp = new Sexp(); 17 | sexp.hd = h; 18 | sexp.tl = t; 19 | sexp.pname = ""; 20 | sexp.nval = 0; 21 | return sexp; 22 | }; 23 | Sexp.createFromString = function (s) { 24 | var sexp = new Sexp(); 25 | sexp.at = true; 26 | sexp.pname = s; 27 | sexp.nval = 0; 28 | sexp.hd = sexp; 29 | sexp.tl = sexp; 30 | sexp.vstk = [sexp]; 31 | return sexp; 32 | }; 33 | Sexp.createFromNumber = function (n) { 34 | var sexp = new Sexp(); 35 | sexp.at = true; 36 | sexp.nmb = true; 37 | sexp.nval = n; 38 | sexp.pname = n.toString(); 39 | sexp.hd = sexp; 40 | sexp.tl = sexp; 41 | sexp.vstk = [sexp]; 42 | return sexp; 43 | }; 44 | 45 | Sexp.prototype = { 46 | two: function () { 47 | return this.tl.hd; 48 | } 49 | , three: function () { 50 | return this.tl.tl.hd; 51 | } 52 | , four: function () { 53 | return this.tl.tl.tl.hd; 54 | } 55 | , bad: function () { 56 | if (this.at) return this.pname === ")"; 57 | return this.hd.bad() || this.tl.bad(); 58 | } 59 | , toString: function () { 60 | var stringify = function (x) { 61 | if (x.at && x.pname !== "") { 62 | this.str += x.pname; 63 | return; 64 | } 65 | this.str += "("; 66 | while (!x.at) { 67 | stringify(x.hd); 68 | x = x.tl; 69 | if (!x.at) this.str += " "; 70 | } 71 | this.str += ")"; 72 | }; 73 | this.str = ""; 74 | stringify(this); 75 | var ret = this.str; 76 | this.str = null; 77 | return ret; 78 | } 79 | }; 80 | 81 | 82 | 83 | }(window || exports)); 84 | -------------------------------------------------------------------------------- /book-examples/fixedpoint.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[[ 4 | 5 | A LISP expression that evaluates to itself! 6 | 7 | Let f(x): x -> (('x)('x)) 8 | 9 | Then (('f)('f)) is a fixed point. 10 | 11 | ]]]]] 12 | 13 | [Here is the fixed point done by hand:] 14 | 15 | ( 16 | 'lambda(x) cons cons "' cons x nil 17 | cons cons "' cons x nil 18 | nil 19 | 20 | 'lambda(x) cons cons "' cons x nil 21 | cons cons "' cons x nil 22 | nil 23 | ) 24 | 25 | expression ((' (lambda (x) (cons (cons ' (cons x nil)) (cons 26 | (cons ' (cons x nil)) nil)))) (' (lambda (x) (cons 27 | (cons ' (cons x nil)) (cons (cons ' (cons x nil)) 28 | nil))))) 29 | value ((' (lambda (x) (cons (cons ' (cons x nil)) (cons 30 | (cons ' (cons x nil)) nil)))) (' (lambda (x) (cons 31 | (cons ' (cons x nil)) (cons (cons ' (cons x nil)) 32 | nil))))) 33 | 34 | 35 | [Now let's construct the fixed point.] 36 | 37 | define (f x) let y [be] cons "' cons x nil [y is ('x) ] 38 | [return] cons y cons y nil [return (('x)('x))] 39 | 40 | define f 41 | value (lambda (x) ((' (lambda (y) (cons y (cons y nil))) 42 | ) (cons ' (cons x nil)))) 43 | 44 | 45 | [Here we try f:] 46 | 47 | (f x) 48 | 49 | expression (f x) 50 | value ((' x) (' x)) 51 | 52 | 53 | [Here we use f to calculate the fixed point:] 54 | 55 | (f f) 56 | 57 | expression (f f) 58 | value ((' (lambda (x) ((' (lambda (y) (cons y (cons y ni 59 | l)))) (cons ' (cons x nil))))) (' (lambda (x) ((' 60 | (lambda (y) (cons y (cons y nil)))) (cons ' (cons 61 | x nil)))))) 62 | 63 | 64 | [Here we find the value of the fixed point:] 65 | 66 | eval (f f) 67 | 68 | expression (eval (f f)) 69 | value ((' (lambda (x) ((' (lambda (y) (cons y (cons y ni 70 | l)))) (cons ' (cons x nil))))) (' (lambda (x) ((' 71 | (lambda (y) (cons y (cons y nil)))) (cons ' (cons 72 | x nil)))))) 73 | 74 | 75 | [Here we check that it's a fixed point:] 76 | 77 | = (f f) eval (f f) 78 | 79 | expression (= (f f) (eval (f f))) 80 | value true 81 | 82 | 83 | [Just for emphasis:] 84 | 85 | = (f f) eval eval eval eval eval eval (f f) 86 | 87 | expression (= (f f) (eval (eval (eval (eval (eval (eval (f f) 88 | ))))))) 89 | value true 90 | 91 | End of LISP Run 92 | 93 | Elapsed time is 0 seconds. 94 | -------------------------------------------------------------------------------- /book-examples/lemma.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Lemma for 3 | H(y|x) <= H(x,y) - H(x) + c 4 | 5 | We show that 6 | H(x) <= -log_2 Sum_y P((x y)) + c 7 | 8 | Proof: From U construct U' such that 9 | if U(p) = (x y), then U'(p) = x. 10 | 11 | Then apply the previous chapter to get 12 | H(x) <= -log_2 P'(x) + c 13 | <= -log_2 Sum_y P((x y)) + c 14 | ]]]]] 15 | 16 | define U-prime 17 | 18 | let (is-pair? x) 19 | if atom x false 20 | if atom cdr x false 21 | if atom cdr cdr x true 22 | false 23 | 24 | [run original program for U] 25 | 26 | let v eval read-exp 27 | 28 | [and if is a pair, return first element] 29 | 30 | if (is-pair? v) car v 31 | 32 | [otherwise loop forever] 33 | 34 | let (loop) [be] (loop) [in] 35 | (loop) 36 | 37 | define U-prime 38 | value ((' (lambda (is-pair?) ((' (lambda (v) (if (is-pai 39 | r? v) (car v) ((' (lambda (loop) (loop))) (' (lamb 40 | da () (loop))))))) (eval (read-exp))))) (' (lambda 41 | (x) (if (atom x) false (if (atom (cdr x)) false ( 42 | if (atom (cdr (cdr x))) true false)))))) 43 | 44 | [Test it!] 45 | 46 | run-utm-on bits' xyz 47 | 48 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 49 | (bits (' xyz))))) 50 | value xyz 51 | 52 | run-utm-on bits' cons a nil 53 | 54 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 55 | (bits (' (cons a nil)))))) 56 | value (a) 57 | 58 | run-utm-on bits' cons a cons b nil 59 | 60 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 61 | (bits (' (cons a (cons b nil))))))) 62 | value (a b) 63 | 64 | run-utm-on bits' cons a cons b cons c nil 65 | 66 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 67 | (bits (' (cons a (cons b (cons c nil)))))))) 68 | value (a b c) 69 | 70 | cadr try 99 U-prime bits' xyz 71 | 72 | expression (car (cdr (try 99 U-prime (bits (' xyz))))) 73 | value out-of-time 74 | 75 | cadr try 99 U-prime bits' cons a nil 76 | 77 | expression (car (cdr (try 99 U-prime (bits (' (cons a nil)))) 78 | )) 79 | value out-of-time 80 | 81 | cadr try 99 U-prime bits' cons a cons b nil 82 | 83 | expression (car (cdr (try 99 U-prime (bits (' (cons a (cons b 84 | nil))))))) 85 | value a 86 | 87 | cadr try 99 U-prime bits' cons a cons b cons c nil 88 | 89 | expression (car (cdr (try 99 U-prime (bits (' (cons a (cons b 90 | (cons c nil)))))))) 91 | value out-of-time 92 | -------------------------------------------------------------------------------- /book-examples/turing.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[[ 4 | 5 | Proof that the halting problem is unsolvable by using 6 | it to construct a LISP expression that halts iff it doesn't. 7 | 8 | ]]]]] 9 | 10 | define (turing x) 11 | [Insert supposed halting algorithm here.] 12 | let (halts? S-exp) false [<=============] 13 | [Form ('x)] 14 | let y [be] cons "' cons x nil [in] 15 | [Form (('x)('x))] 16 | let z [be] display cons y cons y nil [in] 17 | [If (('x)('x)) has a value, then loop forever, otherwise halt] 18 | if (halts? z) [then] eval z [loop forever] 19 | [else] nil [halt] 20 | 21 | define turing 22 | value (lambda (x) ((' (lambda (halts?) ((' (lambda (y) ( 23 | (' (lambda (z) (if (halts? z) (eval z) nil))) (dis 24 | play (cons y (cons y nil)))))) (cons ' (cons x nil 25 | ))))) (' (lambda (S-exp) false)))) 26 | 27 | 28 | [ 29 | (turing turing) decides whether it itself has a value, 30 | then does the opposite! 31 | 32 | Here we suppose it doesn't have a value, 33 | so it turns out that it does: 34 | ] 35 | 36 | (turing turing) 37 | 38 | expression (turing turing) 39 | display ((' (lambda (x) ((' (lambda (halts?) ((' (lambda ( 40 | y) ((' (lambda (z) (if (halts? z) (eval z) nil))) 41 | (display (cons y (cons y nil)))))) (cons ' (cons x 42 | nil))))) (' (lambda (S-exp) false))))) (' (lambda 43 | (x) ((' (lambda (halts?) ((' (lambda (y) ((' (lam 44 | bda (z) (if (halts? z) (eval z) nil))) (display (c 45 | ons y (cons y nil)))))) (cons ' (cons x nil))))) ( 46 | ' (lambda (S-exp) false)))))) 47 | value () 48 | 49 | 50 | define (turing x) 51 | [Insert supposed halting algorithm here.] 52 | let (halts? S-exp) true [<==============] 53 | [Form ('x)] 54 | let y [be] cons "' cons x nil [in] 55 | [Form (('x)('x))] 56 | let z [be] [[[[display]]]] cons y cons y nil [in] 57 | [If (('x)('x)) has a value, then loop forever, otherwise halt] 58 | if (halts? z) [then] eval z [loop forever] 59 | [else] nil [halt] 60 | 61 | define turing 62 | value (lambda (x) ((' (lambda (halts?) ((' (lambda (y) ( 63 | (' (lambda (z) (if (halts? z) (eval z) nil))) (con 64 | s y (cons y nil))))) (cons ' (cons x nil))))) (' ( 65 | lambda (S-exp) true)))) 66 | 67 | 68 | [ 69 | And here we suppose it does have a value, 70 | so it turns out that it doesn't. 71 | 72 | It loops forever evaluating itself again and again! 73 | ] 74 | 75 | (turing turing) 76 | 77 | expression (turing turing) 78 | Storage overflow! 79 | -------------------------------------------------------------------------------- /book-examples/godel.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[[ 4 | 5 | A LISP expression that asserts that it itself is unprovable! 6 | 7 | Let g(x): x -> (is-unprovable (value-of (('x)('x)))) 8 | 9 | Then (is-unprovable (value-of (('g)('g)))) 10 | asserts that it itself is not a theorem! 11 | 12 | ]]]]] 13 | 14 | define (g x) 15 | let (L x y) cons x cons y nil [Makes x and y into list.] 16 | (L is-unprovable (L value-of (L (L "' x) (L "' x)))) 17 | 18 | define g 19 | value (lambda (x) ((' (lambda (L) (L is-unprovable (L va 20 | lue-of (L (L ' x) (L ' x)))))) (' (lambda (x y) (c 21 | ons x (cons y nil)))))) 22 | 23 | 24 | [Here we try g:] 25 | 26 | (g x) 27 | 28 | expression (g x) 29 | value (is-unprovable (value-of ((' x) (' x)))) 30 | 31 | 32 | [ 33 | Here we calculate the LISP expression 34 | that asserts its own unprovability: 35 | ] 36 | 37 | (g g) 38 | 39 | expression (g g) 40 | value (is-unprovable (value-of ((' (lambda (x) ((' (lamb 41 | da (L) (L is-unprovable (L value-of (L (L ' x) (L 42 | ' x)))))) (' (lambda (x y) (cons x (cons y nil)))) 43 | ))) (' (lambda (x) ((' (lambda (L) (L is-unprovabl 44 | e (L value-of (L (L ' x) (L ' x)))))) (' (lambda ( 45 | x y) (cons x (cons y nil)))))))))) 46 | 47 | 48 | [Here we extract the part that it uses to name itself:] 49 | 50 | cadr cadr (g g) 51 | 52 | expression (car (cdr (car (cdr (g g))))) 53 | value ((' (lambda (x) ((' (lambda (L) (L is-unprovable ( 54 | L value-of (L (L ' x) (L ' x)))))) (' (lambda (x y 55 | ) (cons x (cons y nil))))))) (' (lambda (x) ((' (l 56 | ambda (L) (L is-unprovable (L value-of (L (L ' x) 57 | (L ' x)))))) (' (lambda (x y) (cons x (cons y nil) 58 | ))))))) 59 | 60 | 61 | [Here we evaluate the name to get back the entire expression:] 62 | 63 | eval cadr cadr (g g) 64 | 65 | expression (eval (car (cdr (car (cdr (g g)))))) 66 | value (is-unprovable (value-of ((' (lambda (x) ((' (lamb 67 | da (L) (L is-unprovable (L value-of (L (L ' x) (L 68 | ' x)))))) (' (lambda (x y) (cons x (cons y nil)))) 69 | ))) (' (lambda (x) ((' (lambda (L) (L is-unprovabl 70 | e (L value-of (L (L ' x) (L ' x)))))) (' (lambda ( 71 | x y) (cons x (cons y nil)))))))))) 72 | 73 | 74 | [Here we check that it worked:] 75 | 76 | = (g g) eval cadr cadr (g g) 77 | 78 | expression (= (g g) (eval (car (cdr (car (cdr (g g))))))) 79 | value true 80 | 81 | End of LISP Run 82 | 83 | Elapsed time is 0 seconds. 84 | -------------------------------------------------------------------------------- /book-examples/exec.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Given an expr to enumerate (program output) pairs, 3 | we simulate the Turing machine defined this way. 4 | We assume this r.e. set of programs is prefix free, 5 | i.e., no extension of a valid program is a valid 6 | program. If so, we will carry out this simulation 7 | in a self-delimiting way, i.e., we won't read any 8 | unnecessary bits of the program. 9 | ]]]]] 10 | 11 | define pi 12 | 13 | [this is the prefix to put in front of the expr to 14 | enumerate the infinite set of (program output) pairs] 15 | 16 | [graph is an unending expression for (p o) pairs] 17 | let graph read-exp 18 | 19 | [program read so far; initialize to empty bit string] 20 | let p nil 21 | 22 | let (look-for p [in] pairs) 23 | if atom pairs false 24 | [(add new macro caar -> car car to interpreter?)] 25 | if = p car car pairs [does first pair start with p?] 26 | car pairs [if so, return first pair] 27 | [otherwise, keep looking] 28 | (look-for p [in] cdr pairs) 29 | 30 | let (look-for-extension-of p [in] pairs) 31 | if atom pairs false 32 | if (is-prefix? p car car pairs) 33 | true 34 | (look-for-extension-of p [in] cdr pairs) 35 | 36 | let (is-prefix? p q) [is p a prefix of q?] 37 | if atom p true 38 | if atom q false 39 | if = car p car q 40 | (is-prefix? cdr p cdr q) 41 | false 42 | 43 | let (loop t) 44 | [run for time t expr to generate (program output) pairs] 45 | [pairs are displayed by graph] 46 | let pairs debug caddr try debug t graph nil 47 | let found-it? (look-for p pairs) [found pair with program p?] 48 | if found-it? cadr found-it? [if so, we have output for p!] 49 | [(if found-it? isn't false, then it's considered true)] 50 | [is an extension of p in there?] 51 | if (look-for-extension-of p [in] pairs) 52 | [if so, read another bit of p] 53 | [then] let p debug append p cons read-bit nil 54 | (loop + t 1) [and generate more pairs] 55 | [don't read more of p, just generate more pairs] 56 | [else] (loop + t 1) 57 | 58 | [initialize time t to 0] 59 | (loop 0) 60 | 61 | [graph = (1 0) (01 1) (001 2) (0001 3) (00001 4) etc.] 62 | define graph 63 | let (loop p n) 64 | [do!] cons display cons p cons n nil 65 | (loop cons 0 p + 1 n) 66 | (loop '(1) 0) 67 | 68 | [test it!] 69 | 70 | try 10 graph nil 71 | 72 | run-utm-on 73 | 74 | append 75 | 76 | bits pi 77 | 78 | append 79 | 80 | bits graph 81 | 82 | '(0 0 0 1) 83 | -------------------------------------------------------------------------------- /book-examples/xgodel2.l: -------------------------------------------------------------------------------- 1 | [godel2.l] 2 | 3 | [Show that a formal system of complexity N] 4 | [can't prove that a specific object has] 5 | [complexity > N + 4696.] 6 | [Formal system is a never halting lisp expression] 7 | [that output pairs (lisp object, lower bound] 8 | [on its complexity). E.g., (x 4) means] 9 | [that x has complexity H(x) greater than or equal to 4.] 10 | 11 | [Examine pairs to see if 2nd element is greater than lower bound.] 12 | [Returns false to indicate not found, or pair if found.] 13 | define (examine pairs lower-bound) 14 | if atom pairs false 15 | if < lower-bound cadr car pairs 16 | car pairs 17 | (examine cdr pairs lower-bound) 18 | (examine '((x 2)(y 3)) 0) 19 | (examine '((x 2)(y 3)) 1) 20 | (examine '((x 2)(y 3)) 2) 21 | (examine '((x 2)(y 3)) 3) 22 | (examine '((x 2)(y 3)) 4) 23 | 24 | [This is an identity function with the size-effect of] 25 | [displaying the number of bits in a binary string.] 26 | define (display-number-of-bits string) 27 | cadr cons display length string cons string nil 28 | 29 | [This is the universal Turing machine U followed by its program.] 30 | cadr try no-time-limit 'eval read-exp 31 | 32 | [Display number of bits in entire program.] 33 | (display-number-of-bits 34 | 35 | append [Append prefix and data.] 36 | 37 | [Display number of bits in the prefix.] 38 | (display-number-of-bits bits ' 39 | 40 | [Examine pairs to see if 2nd element is greater than lower bound.] 41 | [Returns false to indicate not found, or pair if found.] 42 | let (examine pairs lower-bound) 43 | if atom pairs false 44 | if < lower-bound cadr car pairs 45 | car pairs 46 | (examine cdr pairs lower-bound) 47 | 48 | [] 49 | [Main Loop - t is time limit, fas is bits of formal axiomatic system read so far.] 50 | let (loop t fas) [Run formal axiomatic system again.] 51 | let v debug try debug t 'eval read-exp debug fas 52 | [Look for theorem which is pair with 2nd element > # of bits read + size of this prefix.] 53 | let s (examine caddr v debug + length fas 4696) 54 | if s car s [Found it! Output first element of theorem and halt. Contradiction!] 55 | if = car v success failure [Surprise, formal system halts, so we do too.] 56 | if = cadr v out-of-data (loop t append fas cons read-bit nil) 57 | [Read another bit of the formal axiomatic system.] 58 | if = cadr v out-of-time (loop + t 1 fas) 59 | [Increase time limit] 60 | unexpected-condition [This should never happen.] 61 | [] 62 | (loop 0 nil) [Initially, 0 time limit and no bits of formal axiomatic system read.] 63 | 64 | ) [end of prefix, start of formal axiomatic system] 65 | 66 | bits ' display'(x 4881) 67 | 68 | ) [end of entire program for universal Turing machine U] 69 | -------------------------------------------------------------------------------- /book-examples/sets.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | 3 | Elementary Set Theory in LISP (finite sets) 4 | 5 | ]]]]] 6 | 7 | [Set membership predicate:] 8 | 9 | define (member? e[lement] set) 10 | [Is set empty?] 11 | if atom set [then] false [else] 12 | [Is the element that we are looking for the first element?] 13 | if = e car set [then] true [else] 14 | [recursion step!] 15 | [return] (member? e cdr set) 16 | 17 | (member? 1 '(1 2 3)) 18 | (member? 4 '(1 2 3)) 19 | 20 | [Subset predicate:] 21 | 22 | define (subset? set1 set2) 23 | [Is the first set empty?] 24 | if atom set1 [then] true [else] 25 | [Is the first element of the first set in the second set?] 26 | if (member? car set1 set2) 27 | [then] [recursion!] (subset? cdr set1 set2) 28 | [else] false 29 | 30 | (subset? '(1 2) '(1 2 3)) 31 | (subset? '(1 4) '(1 2 3)) 32 | 33 | [Set union:] 34 | 35 | define (union x y) 36 | [Is the first set empty?] 37 | if atom x [then] [return] y [else] 38 | [Is the first element of the first set in the second set?] 39 | if (member? car x y) 40 | [then] [return] (union cdr x y) 41 | [else] [return] cons car x (union cdr x y) 42 | 43 | (union '(1 2 3) '(2 3 4)) 44 | 45 | [Union of a list of sets:] 46 | 47 | define (unionl l) if atom l nil (union car l (unionl cdr l)) 48 | 49 | (unionl '((1 2) (2 3) (3 4))) 50 | 51 | [Set intersection:] 52 | 53 | define (intersection x y) 54 | [Is the first set empty?] 55 | if atom x [then] [return] nil [empty set] [else] 56 | [Is the first element of the first set in the second set?] 57 | if (member? car x y) 58 | [then] [return] cons car x (intersection cdr x y) 59 | [else] [return] (intersection cdr x y) 60 | 61 | (intersection '(1 2 3) '(2 3 4)) 62 | 63 | [Relative complement of two sets x and y = x - y:] 64 | 65 | define (complement x y) 66 | [Is the first set empty?] 67 | if atom x [then] [return] nil [empty set] [else] 68 | [Is the first element of the first set in the second set?] 69 | if (member? car x y) 70 | [then] [return] (complement cdr x y) 71 | [else] [return] cons car x (complement cdr x y) 72 | 73 | (complement '(1 2 3) '(2 3 4)) 74 | 75 | 76 | [Cartesian product of an element with a list:] 77 | 78 | define (product1 e y) 79 | if atom y 80 | [then] nil 81 | [else] cons cons e cons car y nil (product1 e cdr y) 82 | 83 | (product1 3 '(4 5 6)) 84 | 85 | [Cartesian product of two sets = set of ordered pairs:] 86 | 87 | define (product x y) 88 | [Is the first set empty?] 89 | if atom x [then] [return] nil [empty set] [else] 90 | [return] (union (product1 car x y) (product cdr x y)) 91 | 92 | (product '(1 2 3) '(x y z)) 93 | 94 | [Product of an element with a list of sets:] 95 | 96 | define (product2 e y) 97 | if atom y 98 | [then] nil 99 | [else] cons cons e car y (product2 e cdr y) 100 | 101 | (product2 3 '((4 5) (5 6) (6 7))) 102 | 103 | [Set of all subsets of a given set:] 104 | 105 | define (subsets x) 106 | if atom x 107 | [then] '(()) [else] 108 | let y [be] (subsets cdr x) [in] 109 | (union y (product2 car x y)) 110 | 111 | (subsets '(1 2 3)) 112 | length (subsets '(1 2 3)) 113 | (subsets '(1 2 3 4)) 114 | length (subsets '(1 2 3 4)) 115 | -------------------------------------------------------------------------------- /book-examples/xomega3.l: -------------------------------------------------------------------------------- 1 | [omega3.l] 2 | 3 | [Show that] 4 | [ H(Omega_n) > n - 9488.] 5 | [Omega_n is the first n bits of Omega,] 6 | [where we choose] 7 | [ Omega = xxx0111111...] 8 | [instead of] 9 | [ Omega = xxx1000000...] 10 | [if necessary.] 11 | 12 | [This is an identity function with the size-effect of] 13 | [displaying the length in bits of the binary prefix.] 14 | define (display-length-of-prefix prefix) 15 | cadr cons display length prefix cons prefix nil 16 | 17 | cadr try no-time-limit 'eval read-exp [Universal Turing machine U ---] 18 | 19 | display 20 | [--- followed by its program.] 21 | append [Append prefix and data.] 22 | 23 | [Code to display size of prefix in bits.] 24 | (display-length-of-prefix bits ' 25 | 26 | [] 27 | [Omega2.l follows.] 28 | [] 29 | 30 | let (count-halt prefix time bits-left-to-extend) 31 | if = bits-left-to-extend 0 32 | if = success car try time 'eval read-exp prefix 33 | 1 0 34 | + (count-halt append prefix '(0) time - bits-left-to-extend 1) 35 | (count-halt append prefix '(1) time - bits-left-to-extend 1) 36 | 37 | let (omega k) cons (count-halt nil k k) 38 | cons / 39 | cons ^ 2 k 40 | nil 41 | 42 | [] 43 | [Read and execute from remainder of tape] 44 | [a program to compute an n-bit] 45 | [initial piece of Omega.] 46 | [] 47 | let w debug eval debug read-exp 48 | 49 | [] 50 | [Convert Omega to ratio of integers,] 51 | [i.e., from a bit string to a rational number.] 52 | [] 53 | let n length w 54 | let w debug cons base2-to-10 w 55 | cons / 56 | cons ^ 2 n 57 | nil 58 | [] 59 | let (loop k) [Main Loop ---] 60 | let x debug (omega debug k) [Compute the kth lower bound on Omega.] 61 | if debug (<=rat w x) (big nil k n) [Are the first n bits OK? If not, bump k.] 62 | (loop + k 1) [If so, form the union of all output of n-bit] 63 | [programs within time k, output it, and halt.] 64 | [All n-bit programs that ever halt halt by time k.] 65 | [Thus this union is bigger than anything of complexity] 66 | [less than or equal to n!] 67 | [ ] 68 | [This total output will be bigger than each individual output,] 69 | [and therefore must come from a program with more than n bits.] 70 | [Therefore this program itself must be more than n bits long.] 71 | [I.e., 9488 + H(Omega_n) > n. Q.E.D.] 72 | [] 73 | 74 | [Compare two rational numbers, i.e., is x= (a / b) <= y= (c / d)?] 75 | let (<=rat x y) 76 | let a car debug x 77 | let b caddr x 78 | let c car debug y 79 | let d caddr y 80 | <= * a d * b c 81 | 82 | [Union of all output of n-bit programs within time k.] 83 | let (big prefix time bits-left-to-add) 84 | if = 0 bits-left-to-add 85 | try time 'eval read-exp prefix 86 | append (big append prefix '(0) time - bits-left-to-add 1) 87 | (big append prefix '(1) time - bits-left-to-add 1) 88 | 89 | (loop 0) [Start main loop running with k = 0.] 90 | 91 | ) [end of prefix] 92 | 93 | bits ' [Here is the data: an optimal program to compute n bits of Omega.] 94 | 95 | '(0 0 0 0 0 0 0 1) [n = 8! Are these really the first 8 bits of Omega?] 96 | -------------------------------------------------------------------------------- /book-examples/decomp.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | FUNDAMENTAL DECOMPOSITION 3 | We prove here that 4 | H(y|x) <= H_C(x,y) - H(x) + c 5 | ]]]]] 6 | 7 | define (all-together x*) 8 | 9 | let c debug 100 [constant to satisfy Kraft (see lemma)] 10 | 11 | let x debug run-utm-on debug x* 12 | 13 | let H-of-x debug length x* 14 | 15 | [programs we've discovered that calculate pairs 16 | starting with x] 17 | let programs nil 18 | 19 | let (stage n) 20 | [generate requirements for all new programs we've 21 | discovered that produce (x y) pairs] 22 | let programs 23 | (add-to-set debug (halts? nil debug n) programs) 24 | (stage + n 1) 25 | 26 | [at stage n = 0, 1, 2, 3, ...] 27 | [look at all programs with <=n bits that halt within time n] 28 | [returns list of all of them that produce pairs (x y)] 29 | let (halts? p bits-left) 30 | let v try n C p [C is eval read-exp if C = U] 31 | if = success car v (look-at cadr v) 32 | if = 0 bits-left nil 33 | append (halts? append p cons 0 nil - bits-left 1) 34 | (halts? append p cons 1 nil - bits-left 1) 35 | 36 | [returns (p) if C(p) = (x y), otherwise ()] 37 | let (look-at v) 38 | if (and (is-pair v) 39 | = x car v ) cons p nil 40 | nil 41 | 42 | [logical "and"] 43 | let (and p q) 44 | if p q false 45 | 46 | [is x a pair?] 47 | let (is-pair? x) 48 | if atom x false 49 | if atom cdr x false 50 | if atom cdr cdr x true 51 | false 52 | 53 | [is an element in a set?] 54 | let (is-in-set? element set) 55 | if atom set false 56 | if = element car set true 57 | (is-in-set? element cdr set) 58 | 59 | [forms set union avoiding duplicates, 60 | and makes requirement for each new find] 61 | let (add-to-set new old) 62 | if atom new old 63 | let first-new car new 64 | let rest-new cdr new 65 | if (is-in-set? first-new old) (add-to-set rest-new old) 66 | (do (make-requirement first-new) 67 | cons first-new (add-to-set rest-new old) 68 | ) 69 | 70 | [first argument discarded, done for side-effect only!] 71 | let (do x y) y 72 | 73 | [given new p such that C(p) = (x y), 74 | we produce the requirement for C_x 75 | that there be a program for y that is |p|-H(x)+c bits long] 76 | let (make-requirement p) 77 | display cons cadr cadr try no-time-limit C p 78 | cons - + c length p H-of-x 79 | nil 80 | 81 | let C ' [here eval read-exp gives U] 82 | [test case special-purpose computer C here in place of U:] 83 | [C(00100001) with x-1 and y-1 0's gives pair (x xy)] 84 | [loop function gives number of bits up to next 1 bit] 85 | let (loop n) 86 | if = 1 read-bit n 87 | (loop + n 1) 88 | let x (loop 1) 89 | let y (loop 1) 90 | cons x cons * x y nil 91 | 92 | [HERE GOES!] 93 | (stage 0) 94 | 95 | define x* 3 96 | length bits x* 97 | 98 | [give all-together x*] 99 | try 60 cons cons "' 100 | cons all-together 101 | nil 102 | cons cons "' 103 | cons bits x* 104 | nil 105 | nil 106 | nil 107 | 108 | define x* 4 109 | length bits x* 110 | 111 | [give all-together x*] 112 | try 60 cons cons "' 113 | cons all-together 114 | nil 115 | cons cons "' 116 | cons bits x* 117 | nil 118 | nil 119 | nil 120 | -------------------------------------------------------------------------------- /book-examples/martin-lof.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Martin-Lof random 3 | iff it is Chaitin random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [First part: not M-L random ===> not Ch random] 16 | 17 | [We create the following set of requirements] 18 | [(output, size-of-program)] 19 | [ (s, |s|-n) : s in A_{n^2}, n >= 2 ] 20 | 21 | [Stage k>=0, look at all A_{n^2} n = 2 to 2+k for time k.] 22 | [Then have to combine stage 0, stage 1,...] 23 | [and eliminate duplicates] 24 | 25 | [infinite computation that displays strings] 26 | [in cover A_m with measure mu <= 1/2^m] 27 | define (A m) 28 | cdr cons 29 | [test case, A_m = string of m 1's] 30 | display base10-to-2 - ^ 2 m 1 31 | nil 32 | 33 | define A 34 | value (lambda (m) (cdr (cons (display (base10-to-2 (- (^ 35 | 2 m) 1))) nil))) 36 | 37 | define (is-in? x l) [is x in the list l?] 38 | if atom l false 39 | if = x car l true 40 | (is-in? x cdr l) 41 | 42 | define is-in? 43 | value (lambda (x l) (if (atom l) false (if (= x (car l)) 44 | true (is-in? x (cdr l))))) 45 | 46 | define (convert-to-requirements cover n) [display requirements] 47 | if atom cover requirements [finished?] 48 | let s car cover [get first string] 49 | let cover cdr cover [get rest of strings] 50 | let requirement 51 | cons s cons - length s n nil [form (s, |s|-n)] 52 | if (is-in? requirement requirements) [duplicate?] 53 | [yes] (convert-to-requirements cover n) 54 | [no] let requirements cons display requirement requirements 55 | (convert-to-requirements cover n) 56 | 57 | define convert-to-requirements 58 | value (lambda (cover n) (if (atom cover) requirements (( 59 | ' (lambda (s) ((' (lambda (cover) ((' (lambda (req 60 | uirement) (if (is-in? requirement requirements) (c 61 | onvert-to-requirements cover n) ((' (lambda (requi 62 | rements) (convert-to-requirements cover n))) (cons 63 | (display requirement) requirements))))) (cons s ( 64 | cons (- (length s) n) nil))))) (cdr cover)))) (car 65 | cover)))) 66 | 67 | define (stage k) 68 | if = k 4 stop! [[[stop infinite computation!!!]]] 69 | let (loop i) [i = 0 to k] 70 | if > i k (stage + k 1) [go to next stage] 71 | let n + 2 i [n = 2 + i] 72 | let expr cons cons "' cons A nil 73 | cons * n n nil 74 | let cover caddr try k expr nil [caddr = displays] 75 | let requirements (convert-to-requirements cover n) 76 | (loop + i 1) [bump i] 77 | [initialize i] 78 | (loop 0) 79 | 80 | define stage 81 | value (lambda (k) (if (= k 4) stop! ((' (lambda (loop) ( 82 | loop 0))) (' (lambda (i) (if (> i k) (stage (+ k 1 83 | )) ((' (lambda (n) ((' (lambda (expr) ((' (lambda 84 | (cover) ((' (lambda (requirements) (loop (+ i 1))) 85 | ) (convert-to-requirements cover n)))) (car (cdr ( 86 | cdr (try k expr nil))))))) (cons (cons ' (cons A n 87 | il)) (cons (* n n) nil))))) (+ 2 i)))))))) 88 | 89 | [to remove duplicates] 90 | define requirements () 91 | 92 | define requirements 93 | value () 94 | 95 | [run it] 96 | (stage 0) 97 | 98 | expression (stage 0) 99 | display ((1 1 1 1) 2) 100 | display ((1 1 1 1 1 1 1 1 1) 6) 101 | display ((1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) 12) 102 | display ((1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 103 | 1) 20) 104 | value stop! 105 | -------------------------------------------------------------------------------- /book-examples/occam.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Occam's razor---Concentration process. 3 | From computer C construct C' such that 4 | if P_C(x) >= 1/2^k, then 5 | then C' has a k+1 bit program for x. 6 | Hence H(x) <= -log_2 P_C(x) + c 7 | where c depends only on C, not on x. 8 | ]]]]] 9 | 10 | define all-together 11 | 12 | [this is used to avoid duplicate requirements for C'] 13 | let previous-requirements nil 14 | 15 | [test case special-purpose computer C:] 16 | [ignores odd bits, multiplies by ten until hits a 1] 17 | [this C has many programs that do the same job!] 18 | [[to put U here instead, let C be 'eval read-exp]] 19 | let C ' 20 | let (loop n) 21 | let ignore-it [be] read-bit [skip bit] 22 | if = 1 read-bit [then return] n 23 | [else] (loop * 10 n) 24 | (loop 10) 25 | 26 | [stage n = 0, 1, 2, ... of overall concentration process] 27 | [look at all n-bit programs for C, run them for time n] 28 | [merge (output,multiplicity) pairs, emit requirements for C'] 29 | let (stage n) 30 | let previous-requirements 31 | (make-requirements debug (how-many? nil debug n)) 32 | (stage + n 1) 33 | 34 | [produce (output,multiplicity) pairs] 35 | [by running all n-bit programs on C for time n] 36 | let (how-many? p n) 37 | if = n length p 38 | 39 | [run program p for time n] 40 | let v try n [U => 'eval read-exp] C p 41 | if = success car v 42 | 43 | [program ran to completion] 44 | [indicate that it produces] 45 | [its output with multiplicity one] 46 | cons cons cadr v cons 1 nil 47 | nil 48 | 49 | [otherwise program failed] 50 | nil 51 | [empty list of (output,multiplicity) pairs] 52 | 53 | [otherwise use recursion to combine multiplicities] 54 | (merge (how-many? cons 0 p n) 55 | (how-many? cons 1 p n) 56 | ) 57 | 58 | [add one (output,multiplicity) pair to a list of such pairs] 59 | let (merge1 pair list) 60 | if atom list cons pair nil 61 | let first-in-list car list 62 | let rest-of-list cdr list 63 | let output car pair 64 | let multiplicity cadr pair 65 | let output2 car first-in-list 66 | let multiplicity2 cadr first-in-list 67 | if = output output2 68 | [= -> combine multiplicities] 69 | cons cons output cons + multiplicity multiplicity2 nil 70 | rest-of-list 71 | [!= -> don't combine multiplicities] 72 | cons first-in-list 73 | (merge1 pair rest-of-list) 74 | 75 | [combine two lists of (output,multiplicity) pairs] 76 | let (merge list list2) 77 | if atom list list2 78 | (merge1 car list (merge cdr list list2)) 79 | 80 | [exponent in highest power of 2 <= n, n != 0] 81 | let (log2 n) 82 | let (loop power exponent) 83 | let new-power + power power [double it] 84 | let new-exponent + 1 exponent [add 1 to it] 85 | if > new-power n [then return] exponent 86 | [else] (loop new-power new-exponent) 87 | (loop [initial power of two] 1 [initial exponent of 2] 0) 88 | 89 | let (make-requirements list-of-pairs) 90 | if atom list-of-pairs previous-requirements 91 | let first-pair car list-of-pairs 92 | let list-of-pairs cdr list-of-pairs 93 | let output car first-pair 94 | let multiplicity cadr first-pair 95 | let kraft-requirement 96 | cons output cons - + n 1 (log2 multiplicity) nil 97 | let previous-requirements (make-requirements list-of-pairs) 98 | [keep only first appearance of requirement] 99 | if (is-in? kraft-requirement previous-requirements) 100 | previous-requirements 101 | cons debug display kraft-requirement previous-requirements 102 | 103 | let (is-in? x list) [is x in list?] 104 | if atom list false 105 | if = x car list true 106 | (is-in? x cdr list) 107 | 108 | [HERE GOES!] 109 | (stage 0) 110 | 111 | try 60 all-together nil 112 | -------------------------------------------------------------------------------- /book-examples/utm.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[ 4 | First steps with my new construction for 5 | a self-delimiting universal Turing machine. 6 | We show that 7 | H(x,y) <= H(x) + H(y) + c 8 | and determine c. 9 | Consider a bit string x of length |x|. 10 | We also show that 11 | H(x) <= 2|x| + c 12 | and that 13 | H(x) <= |x| + H(the binary string for |x|) + c 14 | and determine both these c's. 15 | ]]] 16 | 17 | [ 18 | Here is the self-delimiting universal Turing machine! 19 | ] 20 | define (U p) cadr try no-time-limit 'eval read-exp p 21 | 22 | define U 23 | value (lambda (p) (car (cdr (try no-time-limit (' (eval 24 | (read-exp))) p)))) 25 | 26 | (U bits 'cons x cons y cons z nil) 27 | 28 | expression (U (bits (' (cons x (cons y (cons z nil)))))) 29 | value (x y z) 30 | 31 | (U append bits 'cons a debug read-exp 32 | bits '(b c d) 33 | ) 34 | 35 | expression (U (append (bits (' (cons a (debug (read-exp))))) 36 | (bits (' (b c d))))) 37 | debug (b c d) 38 | value (a b c d) 39 | 40 | [ 41 | The length of alpha in bits is the 42 | constant c in H(x) <= 2|x| + 2 + c. 43 | ] 44 | define alpha 45 | let (loop) let x read-bit 46 | let y read-bit 47 | if = x y 48 | cons x (loop) 49 | nil 50 | (loop) 51 | 52 | define alpha 53 | value ((' (lambda (loop) (loop))) (' (lambda () ((' (lam 54 | bda (x) ((' (lambda (y) (if (= x y) (cons x (loop) 55 | ) nil))) (read-bit)))) (read-bit))))) 56 | 57 | length bits alpha 58 | 59 | expression (length (bits alpha)) 60 | value 1104 61 | 62 | (U 63 | append 64 | bits alpha 65 | '(0 0 1 1 0 0 1 1 0 1) 66 | ) 67 | 68 | expression (U (append (bits alpha) (' (0 0 1 1 0 0 1 1 0 1))) 69 | ) 70 | value (0 1 0 1) 71 | 72 | (U 73 | append 74 | bits alpha 75 | '(0 0 1 1 0 0 1 1 0 0) 76 | ) 77 | 78 | expression (U (append (bits alpha) (' (0 0 1 1 0 0 1 1 0 0))) 79 | ) 80 | value out-of-data 81 | 82 | [ 83 | The length of beta in bits is the 84 | constant c in H(x,y) <= H(x) + H(y) + c. 85 | ] 86 | define beta 87 | cons eval read-exp 88 | cons eval read-exp 89 | nil 90 | 91 | define beta 92 | value (cons (eval (read-exp)) (cons (eval (read-exp)) ni 93 | l)) 94 | 95 | length bits beta 96 | 97 | expression (length (bits beta)) 98 | value 432 99 | 100 | (U 101 | append 102 | bits beta 103 | append 104 | bits 'cons a cons b cons c nil 105 | bits 'cons x cons y cons z nil 106 | ) 107 | 108 | expression (U (append (bits beta) (append (bits (' (cons a (c 109 | ons b (cons c nil))))) (bits (' (cons x (cons y (c 110 | ons z nil)))))))) 111 | value ((a b c) (x y z)) 112 | 113 | (U 114 | append 115 | bits beta 116 | append 117 | append bits alpha '(0 0 1 1 0 0 1 1 0 1) 118 | append bits alpha '(1 1 0 0 1 1 0 0 1 0) 119 | ) 120 | 121 | expression (U (append (bits beta) (append (append (bits alpha 122 | ) (' (0 0 1 1 0 0 1 1 0 1))) (append (bits alpha) 123 | (' (1 1 0 0 1 1 0 0 1 0)))))) 124 | value ((0 1 0 1) (1 0 1 0)) 125 | 126 | [ 127 | The length of gamma in bits is the 128 | constant c in H(x) <= |x| + H(|x|) + c 129 | ] 130 | define gamma 131 | let (loop k) 132 | if = 0 k nil 133 | cons read-bit (loop - k 1) 134 | (loop base2-to-10 eval read-exp) 135 | 136 | define gamma 137 | value ((' (lambda (loop) (loop (base2-to-10 (eval (read- 138 | exp)))))) (' (lambda (k) (if (= 0 k) nil (cons (re 139 | ad-bit) (loop (- k 1))))))) 140 | 141 | length bits gamma 142 | 143 | expression (length (bits gamma)) 144 | value 1024 145 | 146 | (U 147 | append 148 | bits gamma 149 | append 150 | [Arbitrary program for U to compute number of bits] 151 | bits' '(1 0 0 0) 152 | [That many bits of data] 153 | '(0 0 0 0 0 0 0 1) 154 | ) 155 | 156 | expression (U (append (bits gamma) (append (bits (' (' (1 0 0 157 | 0)))) (' (0 0 0 0 0 0 0 1))))) 158 | value (0 0 0 0 0 0 0 1) 159 | 160 | End of LISP Run 161 | 162 | Elapsed time is 0 seconds. 163 | -------------------------------------------------------------------------------- /book-examples/chaitin2.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Solovay random 3 | iff it is strong Chaitin random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [Second part: not Ch random ===> not Sol random] 16 | 17 | define (is-in? x l) [is x an element of list l?] 18 | if atom l false 19 | if = x car l true 20 | (is-in? x cdr l) 21 | 22 | define (union x y) [set-theoretic union of two sets x y] 23 | if atom x y 24 | if (is-in? car x y) (union cdr x y) 25 | cons car x (union cdr x y) 26 | 27 | define (is-bit-string? x) [is x a list of 0's and 1's?] 28 | if = x nil true 29 | if atom x false 30 | if = 0 car x (is-bit-string? cdr x) 31 | if = 1 car x (is-bit-string? cdr x) 32 | false 33 | 34 | define C [test computer---real thing is eval read-exp] 35 | let (loop x y) [xx yy zz 01 ===> xyz] 36 | if = x y cons x (loop read-bit read-bit) 37 | nil 38 | (loop read-bit read-bit) 39 | 40 | [ 41 | The hypothesis that 42 | the real number r is not Chaitin random 43 | means that there is a K such that 44 | for infinitely many values of n 45 | H(r_n) < n + K, 46 | where r_n is the first n bits of r. 47 | 48 | For this example, let's suppose that K = 5. 49 | ] 50 | 51 | define K 5 52 | 53 | [ 54 | Our proof depends on the fact that there is a c such that 55 | the probability that an n-bit string s has 56 | H(s) < n + K 57 | is less than 2^{-H(n) + K + c}. 58 | ] 59 | 60 | [ 61 | Now let's do stage N of A_n = n-bit strings s with H(s) < |s| + K. 62 | At stage N we look at all programs p less than n + K bits in size for time up to N. 63 | ] 64 | 65 | define (quasi-compressible N n) 66 | (look-at nil) 67 | 68 | [this routine has free parameters N, n, K, C] 69 | 70 | define (look-at p) [produces quasi-compressible strings of length n] 71 | if = length p + n K [p too long?] 72 | nil 73 | let v try N C ['eval read-exp] p 74 | if = success car v 75 | let w cadr v 76 | if (is-bit-string? w) 77 | if = n length w 78 | cons w nil 79 | nil 80 | nil 81 | [ 82 | Also works with append below instead of union 83 | because duplicates are removed later by (process interval). 84 | ] 85 | (union (look-at append p cons 0 nil) 86 | (look-at append p cons 1 nil)) 87 | 88 | [ 89 | List of intervals in covering so far. 90 | used to avoid overlapping intervals in covering. 91 | 92 | This is easy to do because here because 93 | all intervals are the same length. 94 | ] 95 | define intervals () 96 | 97 | define (process-all x) [process list of intervals x] 98 | if atom x intervals 99 | let intervals append (process car x) intervals 100 | (process-all cdr x) 101 | 102 | define (process interval) [process individual interval] 103 | if (is-in? interval intervals) 104 | [then don't need to repeat it] 105 | nil 106 | [else interval is fine as is] 107 | cons display interval nil 108 | 109 | [ 110 | Put it all together---Here is cover A_n 111 | covering all reals r having n-bit prefix r_n 112 | with H(r_n) < n + K. 113 | 114 | And we have measure \mu A_n <= 2^{-H(n)+K+c} 115 | so that Sum_n \mu A_n <= \Omega 2^{K+c} <= 2^{K+c} < infinity . 116 | 117 | Hence a real r which is not strongly Chaitin random 118 | will be in infinitely many of the A_n, 119 | which have convergent total measure, 120 | and hence will not be Solovay random. 121 | ] 122 | define (A n) 123 | let intervals nil 124 | let (stage N) 125 | if = N 7 stop! [to stop test run---remove if real thing] 126 | let quasi-compressible-strings (quasi-compressible N n) 127 | let intervals (process-all quasi-compressible-strings) 128 | (stage + 1 N) 129 | [go!!!!!] 130 | (stage 0) 131 | 132 | [n = 2, i.e., quasi-compressible 2-bit strings] 133 | (A 2) 134 | -------------------------------------------------------------------------------- /book-examples/exec.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Given an expr to enumerate (program output) pairs, 3 | we simulate the Turing machine defined this way. 4 | We assume this r.e. set of programs is prefix free, 5 | i.e., no extension of a valid program is a valid 6 | program. If so, we will carry out this simulation 7 | in a self-delimiting way, i.e., we won't read any 8 | unnecessary bits of the program. 9 | ]]]]] 10 | 11 | define pi 12 | 13 | [this is the prefix to put in front of the expr to 14 | enumerate the infinite set of (program output) pairs] 15 | 16 | [graph is an unending expression for (p o) pairs] 17 | let graph read-exp 18 | 19 | [program read so far; initialize to empty bit string] 20 | let p nil 21 | 22 | let (look-for p [in] pairs) 23 | if atom pairs false 24 | [(add new macro caar -> car car to interpreter?)] 25 | if = p car car pairs [does first pair start with p?] 26 | car pairs [if so, return first pair] 27 | [otherwise, keep looking] 28 | (look-for p [in] cdr pairs) 29 | 30 | let (look-for-extension-of p [in] pairs) 31 | if atom pairs false 32 | if (is-prefix? p car car pairs) 33 | true 34 | (look-for-extension-of p [in] cdr pairs) 35 | 36 | let (is-prefix? p q) [is p a prefix of q?] 37 | if atom p true 38 | if atom q false 39 | if = car p car q 40 | (is-prefix? cdr p cdr q) 41 | false 42 | 43 | let (loop t) 44 | [run for time t expr to generate (program output) pairs] 45 | [pairs are displayed by graph] 46 | let pairs debug caddr try debug t graph nil 47 | let found-it? (look-for p pairs) [found pair with program p?] 48 | if found-it? cadr found-it? [if so, we have output for p!] 49 | [(if found-it? isn't false, then it's considered true)] 50 | [is an extension of p in there?] 51 | if (look-for-extension-of p [in] pairs) 52 | [if so, read another bit of p] 53 | [then] let p debug append p cons read-bit nil 54 | (loop + t 1) [and generate more pairs] 55 | [don't read more of p, just generate more pairs] 56 | [else] (loop + t 1) 57 | 58 | [initialize time t to 0] 59 | (loop 0) 60 | 61 | define pi 62 | value ((' (lambda (graph) ((' (lambda (p) ((' (lambda (l 63 | ook-for) ((' (lambda (look-for-extension-of) ((' ( 64 | lambda (is-prefix?) ((' (lambda (loop) (loop 0))) 65 | (' (lambda (t) ((' (lambda (pairs) ((' (lambda (fo 66 | und-it?) (if found-it? (car (cdr found-it?)) (if ( 67 | look-for-extension-of p pairs) ((' (lambda (p) (lo 68 | op (+ t 1)))) (debug (append p (cons (read-bit) ni 69 | l)))) (loop (+ t 1)))))) (look-for p pairs)))) (de 70 | bug (car (cdr (cdr (try (debug t) graph nil))))))) 71 | )))) (' (lambda (p q) (if (atom p) true (if (atom 72 | q) false (if (= (car p) (car q)) (is-prefix? (cdr 73 | p) (cdr q)) false)))))))) (' (lambda (p pairs) (if 74 | (atom pairs) false (if (is-prefix? p (car (car pa 75 | irs))) true (look-for-extension-of p (cdr pairs))) 76 | )))))) (' (lambda (p pairs) (if (atom pairs) false 77 | (if (= p (car (car pairs))) (car pairs) (look-for 78 | p (cdr pairs))))))))) nil))) (read-exp)) 79 | 80 | [graph = (1 0) (01 1) (001 2) (0001 3) (00001 4) etc.] 81 | define graph 82 | let (loop p n) 83 | [do!] cons display cons p cons n nil 84 | (loop cons 0 p + 1 n) 85 | (loop '(1) 0) 86 | 87 | define graph 88 | value ((' (lambda (loop) (loop (' (1)) 0))) (' (lambda ( 89 | p n) (cons (display (cons p (cons n nil))) (loop ( 90 | cons 0 p) (+ 1 n)))))) 91 | 92 | [test it!] 93 | 94 | try 10 graph nil 95 | 96 | expression (try 10 graph nil) 97 | value (failure out-of-time (((1) 0) ((0 1) 1) ((0 0 1) 2 98 | ) ((0 0 0 1) 3) ((0 0 0 0 1) 4) ((0 0 0 0 0 1) 5) 99 | ((0 0 0 0 0 0 1) 6) ((0 0 0 0 0 0 0 1) 7) ((0 0 0 100 | 0 0 0 0 0 1) 8))) 101 | 102 | run-utm-on 103 | 104 | append 105 | 106 | bits pi 107 | 108 | append 109 | 110 | bits graph 111 | 112 | '(0 0 0 1) 113 | 114 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 115 | (append (bits pi) (append (bits graph) (' (0 0 0 116 | 1))))))) 117 | debug 0 118 | debug () 119 | debug 1 120 | debug () 121 | debug 2 122 | debug (((1) 0)) 123 | debug (0) 124 | debug 3 125 | debug (((1) 0) ((0 1) 1)) 126 | debug (0 0) 127 | debug 4 128 | debug (((1) 0) ((0 1) 1) ((0 0 1) 2)) 129 | debug (0 0 0) 130 | debug 5 131 | debug (((1) 0) ((0 1) 1) ((0 0 1) 2) ((0 0 0 1) 3)) 132 | debug (0 0 0 1) 133 | debug 6 134 | debug (((1) 0) ((0 1) 1) ((0 0 1) 2) ((0 0 0 1) 3) ((0 0 135 | 0 0 1) 4)) 136 | value 3 137 | -------------------------------------------------------------------------------- /book-examples/chaitin.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | 3 | Show that a formal axiomatic system (fas) can only prove 4 | that finitely many LISP expressions are elegant. 5 | (An expression is elegant if no smaller expression has 6 | the same value.) 7 | 8 | More precisely, show that a fas of LISP complexity N can't 9 | prove that a LISP expression X is elegant if X's size is 10 | greater than N + 356. 11 | 12 | (fas N) returns the theorem proved by the Nth proof 13 | (Nth S-expression) in the fas, or nil if the proof is 14 | invalid, or stop to stop everything. 15 | 16 | ]]]]] 17 | 18 | [ 19 | This expression searches for an elegant expression 20 | that is larger than it is and returns the value of 21 | that expression as its own value. 22 | ] 23 | 24 | define expression [Formal Axiomatic System #1] 25 | let (fas n) if = n 1 '(is-elegant x) 26 | if = n 2 nil 27 | if = n 3 '(is-elegant yyy) 28 | [else] stop 29 | 30 | let (loop n) 31 | let theorem [be] display (fas n) 32 | if = nil theorem [then] (loop + n 1) 33 | if = stop theorem [then] fas-has-stopped 34 | if = is-elegant car theorem 35 | if > display size cadr theorem 36 | display + 356 size fas 37 | [return] eval cadr theorem 38 | [else] (loop + n 1) 39 | [else] (loop + n 1) 40 | 41 | (loop 1) 42 | 43 | [Show that this expression knows its own size.] 44 | 45 | size expression 46 | 47 | [ 48 | Run #1. 49 | 50 | Here it doesn't find an elegant expression 51 | larger than it is: 52 | ] 53 | 54 | eval expression 55 | 56 | define expression [Formal Axiomatic System #2] 57 | let (fas n) if = n 1 '(is-elegant x) 58 | if = n 2 nil 59 | if = n 3 '(is-elegant yyy) 60 | if = n 4 cons is-elegant 61 | cons ^ 10 509 [<=====] 62 | nil 63 | [else] stop 64 | 65 | let (loop n) 66 | let theorem [be] display (fas n) 67 | if = nil theorem [then] (loop + n 1) 68 | if = stop theorem [then] fas-has-stopped 69 | if = is-elegant car theorem 70 | if > display size cadr theorem 71 | display + 356 size fas 72 | [return] eval cadr theorem 73 | [else] (loop + n 1) 74 | [else] (loop + n 1) 75 | 76 | (loop 1) 77 | 78 | [Show that this expression knows its own size.] 79 | 80 | size expression 81 | 82 | [ 83 | Run #2. 84 | 85 | Here it finds an elegant expression 86 | exactly one character larger than it is: 87 | ] 88 | 89 | eval expression 90 | 91 | define expression [Formal Axiomatic System #3] 92 | let (fas n) if = n 1 '(is-elegant x) 93 | if = n 2 nil 94 | if = n 3 '(is-elegant yyy) 95 | if = n 4 cons is-elegant 96 | cons ^ 10 508 [<=====] 97 | nil 98 | [else] stop 99 | 100 | let (loop n) 101 | let theorem [be] display (fas n) 102 | if = nil theorem [then] (loop + n 1) 103 | if = stop theorem [then] fas-has-stopped 104 | if = is-elegant car theorem 105 | if > display size cadr theorem 106 | display + 356 size fas 107 | [return] eval cadr theorem 108 | [else] (loop + n 1) 109 | [else] (loop + n 1) 110 | 111 | (loop 1) 112 | 113 | [Show that this expression knows its own size.] 114 | 115 | size expression 116 | 117 | [ 118 | Run #3. 119 | 120 | Here it finds an elegant expression 121 | exactly the same size as it is: 122 | ] 123 | 124 | eval expression 125 | 126 | define expression [Formal Axiomatic System #4] 127 | let (fas n) if = n 1 '(is-elegant x) 128 | if = n 2 nil 129 | if = n 3 '(is-elegant yyy) 130 | if = n 4 cons is-elegant 131 | cons cons "- 132 | cons ^ 10 600 [<=====] 133 | cons 1 134 | nil 135 | nil 136 | [else] stop 137 | 138 | let (loop n) 139 | let theorem [be] display (fas n) 140 | if = nil theorem [then] (loop + n 1) 141 | if = stop theorem [then] fas-has-stopped 142 | if = is-elegant car theorem 143 | if > display size cadr theorem 144 | display + 356 size fas 145 | [return] eval cadr theorem 146 | [else] (loop + n 1) 147 | [else] (loop + n 1) 148 | 149 | (loop 1) 150 | 151 | [Show that this expression knows its own size.] 152 | 153 | size expression 154 | 155 | [ 156 | Run #4. 157 | 158 | Here it finds an elegant expression 159 | much larger than it is, and evaluates it: 160 | ] 161 | 162 | eval expression 163 | -------------------------------------------------------------------------------- /book-examples/xgodel3.l: -------------------------------------------------------------------------------- 1 | [godel3.l] 2 | 3 | [Show that a formal system of complexity N] 4 | [can't determine more than N + 9488 + 6912] 5 | [= N + 16400 bits of Omega.] 6 | [Formal system is a never halting lisp expression] 7 | [that outputs lists of the form (1 0 X 0 X X X X 1 0).] 8 | [This stands for the fractional part of Omega,] 9 | [and means that these 0,1 bits of Omega are known.] 10 | [X stands for an unknown bit.] 11 | 12 | [Count number of bits in an omega that are determined.] 13 | define (number-of-bits-determined w) 14 | if atom w 0 15 | + (number-of-bits-determined cdr w) 16 | if = X car w 17 | 0 18 | 1 19 | [Test it.] 20 | (number-of-bits-determined '(X X X)) 21 | (number-of-bits-determined '(1 X X)) 22 | (number-of-bits-determined '(1 X 0)) 23 | (number-of-bits-determined '(1 1 0)) 24 | 25 | [Merge bits of data into unknown bits of an omega.] 26 | define (supply-missing-bits w) 27 | if atom w nil 28 | cons if = X car w 29 | read-bit 30 | car w 31 | (supply-missing-bits cdr w) 32 | [Test it.] 33 | cadr try no-time-limit ' 34 | let (supply-missing-bits w) 35 | if atom w nil 36 | cons if = X car w 37 | read-bit 38 | car w 39 | (supply-missing-bits cdr w) 40 | (supply-missing-bits '(0 0 X 0 0 X 0 0 X)) 41 | '(1 1 1) 42 | cadr try no-time-limit ' 43 | let (supply-missing-bits w) 44 | if atom w nil 45 | cons if = X car w 46 | read-bit 47 | car w 48 | (supply-missing-bits cdr w) 49 | (supply-missing-bits '(1 1 X 1 1 X 1 1 1)) 50 | '(0 0) 51 | 52 | [Examine omegas in list w to see if in any one of them] 53 | [the number of bits that are determined is greater than n.] 54 | [Returns false to indicate not found, or what it found.] 55 | define (examine w n) 56 | if atom w false 57 | if < n (number-of-bits-determined car w) 58 | car w 59 | (examine cdr w n) 60 | [Test it.] 61 | (examine '((1 1)(1 1 1)) 0) 62 | (examine '((1 1)(1 1 1)) 1) 63 | (examine '((1 1)(1 1 1)) 2) 64 | (examine '((1 1)(1 1 1)) 3) 65 | (examine '((1 1)(1 1 1)) 4) 66 | 67 | [This is an identity function with the size-effect of] 68 | [displaying the number of bits in a binary string.] 69 | define (display-number-of-bits string) 70 | cadr cons display length string 71 | cons string 72 | nil 73 | 74 | [This is the universal Turing machine U followed by its program.] 75 | cadr try no-time-limit 'eval read-exp 76 | 77 | append [Append missing bits of Omega to rest of program.] 78 | 79 | [Display number of bits in entire program excepting the missing bits of Omega.] 80 | (display-number-of-bits 81 | 82 | append [Append prefix and formal axiomatic system.] 83 | 84 | [Display number of bits in the prefix.] 85 | (display-number-of-bits bits ' 86 | 87 | [Count number of bits in an omega that are determined.] 88 | let (number-of-bits-determined w) 89 | if atom w 0 90 | + (number-of-bits-determined cdr w) 91 | if = X car w 92 | 0 93 | 1 94 | 95 | [Merge bits of data into unknown bits of an omega.] 96 | let (supply-missing-bits w) 97 | if atom w nil 98 | cons if = X car w 99 | read-bit 100 | car w 101 | (supply-missing-bits cdr w) 102 | 103 | [Examine omegas in list w to see if in any one of them] 104 | [the number of bits that are determined is greater than n.] 105 | [Return false to indicate not found, or what it found.] 106 | let (examine w n) 107 | if atom w false 108 | [] 109 | [ if < n (number-of-bits-determined car w) <==== Change n to 1 here so will succeed.] 110 | [] 111 | if < 1 (number-of-bits-determined car w) 112 | car w 113 | (examine cdr w n) 114 | 115 | [] 116 | [Main Loop - t is time limit, fas is bits of formal axiomatic system read so far.] 117 | let (loop t fas) [Run formal axiomatic system again.] 118 | let v debug try debug t 'eval read-exp debug fas 119 | [] 120 | [Look for theorem which determines more than] 121 | [ (c + # of bits read + size of this prefix)] 122 | [bits of Omega. Here c = 9488 is the constant in the inequality] 123 | [ H(Omega_n) > n - c] 124 | [(see omega3.l and omega3.r).] 125 | [] 126 | let s (examine caddr v + 9488 debug + length fas 6912) 127 | if s (supply-missing-bits s) [Found it! Merge in undetermined bits, output result, and halt. Contradiction!] 128 | if = car v success failure [Surprise, formal system halts, so we do too.] 129 | if = cadr v out-of-data (loop t append fas cons read-bit nil) 130 | [Read another bit of the formal axiomatic system.] 131 | if = cadr v out-of-time (loop + t 1 fas) 132 | [Increase time limit.] 133 | unexpected-condition [This should never happen.] 134 | [] 135 | (loop 0 nil) [Initially, 0 time limit and no bits of formal axiomatic system read.] 136 | 137 | ) [end of prefix, start of formal axiomatic system] 138 | 139 | [Toy formal system with only one theorem.] 140 | bits 'display '(1 X 0) 141 | 142 | ) [end of prefix and formal axiomatic system] 143 | 144 | '(1) [Missing bit of Omega that is needed.] 145 | -------------------------------------------------------------------------------- /book-examples/martin-lof2.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Martin-Lof random 3 | iff it is Chaitin random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [Second part: not Ch random ===> not M-L random] 16 | 17 | define (is-in? x l) [is x an element of list l?] 18 | if atom l false 19 | if = x car l true 20 | (is-in? x cdr l) 21 | 22 | define (is-prefix-of? x y) [is bit string x a prefix of bit string y?] 23 | if atom x true 24 | if atom y false 25 | if = car x car y (is-prefix-of? cdr x cdr y) 26 | false 27 | 28 | define (is-bit-string? x) [is x a list of 0's and 1's?] 29 | if = x nil true 30 | if atom x false 31 | if = 0 car x (is-bit-string? cdr x) 32 | if = 1 car x (is-bit-string? cdr x) 33 | false 34 | 35 | define C [test computer---real thing is eval read-exp] 36 | let (loop) [doubles all bits up to & including first 1] 37 | if = 1 read-bit '(1 1) 38 | cons 0 cons 0 (loop) 39 | (loop) 40 | 41 | [Now let's do stage n of A_k = strings s with H(s) <= |s| - k.] 42 | [At stage n we look at programs p up to n bits in size for time up to n.] 43 | 44 | define (compressible-by-k n k) 45 | (look-at nil) 46 | 47 | [this routine has free parameters n, k, C] 48 | 49 | define (look-at p) [produces strings compressible by k within time n] 50 | let v try n C ['eval read-exp] p 51 | if = success car v 52 | let w cadr v 53 | if (is-bit-string? w) 54 | if >= length w + k length p 55 | cons w nil 56 | nil 57 | nil 58 | [otherwise failure] 59 | if = n length p nil [stop!] 60 | append (look-at append p cons 0 nil) 61 | (look-at append p cons 1 nil) 62 | 63 | [list of intervals in covering so far] 64 | [used to avoid overlapping intervals in covering] 65 | define intervals () 66 | 67 | define (process-all x) [process list of intervals x] 68 | if atom x intervals 69 | let intervals append (process car x) intervals 70 | (process-all cdr x) 71 | 72 | define (process interval) [process individual interval] 73 | if (new-interval-covered-by-previous-one? interval intervals) 74 | [then don't need to repeat it] 75 | nil 76 | let holes (new-interval-covers-previous-ones interval intervals) 77 | if atom holes 78 | [then interval is fine as is] 79 | cons display interval nil 80 | [get max granularity needed] 81 | let max (max-length holes) 82 | [convert everything to same granularity] 83 | let holes (extend-all holes max) 84 | [and remove overlap] 85 | (subtract (extend interval max) holes) 86 | 87 | [returns true/false] 88 | define (new-interval-covered-by-previous-one? interval intervals) 89 | if atom intervals false 90 | if (is-prefix-of? car intervals interval) true 91 | (new-interval-covered-by-previous-one? interval cdr intervals) 92 | 93 | [returns set of previous intervals covered by this one] 94 | define (new-interval-covers-previous-ones interval intervals) 95 | if atom intervals nil 96 | if (is-prefix-of? interval car intervals) 97 | [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals) 98 | [else] (new-interval-covers-previous-ones interval cdr intervals) 99 | 100 | [get maximum length of a list of bit strings] 101 | define (max-length list) 102 | if atom list 0 103 | let len1 length car list 104 | let len2 (max-length cdr list) 105 | if > len1 len2 106 | [then] len1 107 | [else] len2 108 | 109 | [produce set of all extensions of a given bit string to a given length] 110 | [(assumed >= to its current length)] 111 | define (extend bit-string len) 112 | if = len length bit-string 113 | [has correct length; return singleton set] 114 | cons bit-string nil 115 | append (extend append bit-string cons 0 nil len) 116 | (extend append bit-string cons 1 nil len) 117 | 118 | [extend all the bit strings in a given list to the same length] 119 | define (extend-all list len) 120 | if atom list nil 121 | append (extend car list len) 122 | (extend-all cdr list len) 123 | 124 | [subtract set of intervals y from set of intervals x] 125 | define (subtract x y) 126 | if atom x nil 127 | if (is-in? car x y) 128 | [then] (subtract cdr x y) 129 | [else] cons debug display car x (subtract cdr x y) 130 | 131 | [ 132 | Put it all together---Here is cover A_k 133 | covering all reals r having any n-bit prefix r_n 134 | with H(r_n) <= n - k. 135 | And we have measure \mu A_k <= 2^{-k+c}. 136 | Actual proof uses A_{k+c} 137 | so that measure \mu A_{k+c} <= 2^{-k}. 138 | Hence a real r with prefixes whose complexity 139 | dips arbitrarily far below their length will be 140 | in all the A_k and hence will not be M-L random. 141 | ] 142 | define (A k) 143 | let intervals nil 144 | let (stage n) 145 | let compressible-strings (compressible-by-k n k) 146 | let intervals (process-all compressible-strings) 147 | if = n 12 stop! [to stop test run---remove if real thing] 148 | (stage + 1 n) 149 | [go!!!!!] 150 | (stage 0) 151 | 152 | [k = compression amount = 8 bits] 153 | (A 8) 154 | -------------------------------------------------------------------------------- /book-examples/utm2.l: -------------------------------------------------------------------------------- 1 | [[[ 2 | RELATIVE COMPLEXITY! 3 | Additional steps in my new construction for 4 | a self-delimiting universal Turing machine. 5 | 6 | We show that 7 | 8 | H(beta) <= n + H(n) + c for n-bit beta 9 | 10 | H(x,y) <= H(x) + H(y) + c 11 | 12 | H(H(x)|x) <= c 13 | 14 | H(x,y) <= H(x) + H(y|x) + c 15 | ]]] 16 | 17 | [ 18 | Here is the self-delimiting universal Turing machine 19 | with NO free data. P is the program. 20 | [Run-utm-on p expands to this.] 21 | ] 22 | define (U p) 23 | cadr try no-time-limit 'eval read-exp p 24 | [Here is the version of U with one piece of free data:] 25 | 26 | define (U2 p q) [q is a program for U for the free data] 27 | cadr try no-time-limit 28 | display cons 'read-exp [run ((read-exp) (' q))] 29 | cons cons "' 30 | cons q 31 | nil 32 | nil 33 | p 34 | [Here's the version given two things, not one:] 35 | 36 | define (U3 p q r) [q, r are programs for U for the free data] 37 | cadr try no-time-limit 38 | display cons 'read-exp [run ((read-exp) (' q) (' r))] 39 | cons cons "' 40 | cons q 41 | nil 42 | cons cons "' 43 | cons r 44 | nil 45 | nil 46 | p 47 | [ 48 | Consider an n-bit string beta. 49 | We show that H(beta) <= n + H(n) + 912. 50 | ] 51 | define pi 52 | let (loop k) 53 | if = k 0 nil 54 | cons read-bit (loop - k 1) 55 | (loop eval read-exp) 56 | [Size it.] 57 | length bits pi 58 | [Use it.] 59 | (U 60 | append bits pi 61 | append bits 12 62 | '(0 0 1 1 1 1 1 1 0 0 0 1) 63 | ) 64 | [ 65 | Proof that H(x,y) <= H(x) + H(y) + 432. 66 | ] 67 | define rho 68 | cons eval read-exp cons eval read-exp nil 69 | [Size it.] 70 | length bits rho 71 | [Use it.] 72 | (U 73 | append bits rho 74 | append bits pi 75 | append bits 5 76 | append '(1 1 1 1 1) 77 | append bits pi 78 | append bits 9 79 | '(0 0 0 0 0 0 0 0 0) 80 | ) 81 | [ 82 | Proof that H(H(x)|x) <= 208. 83 | ] 84 | define (alpha x*) [x* = minimum-size program for x] 85 | length x* [get H(x) from x*] 86 | [Size it.] 87 | length bits alpha 88 | [Use it.] 89 | 90 | (U2 91 | 92 | [This is the program to calculate H(x):] 93 | 94 | bits alpha 95 | 96 | [This is the program x* for x,] 97 | [supposedly smallest possible:] 98 | 99 | bits' + 1 1 100 | 101 | ) 102 | [Check size of program is correct] 103 | * 8 + 1 display size display '+ 1 1 104 | [ 105 | Proof that H(x,y) <= H(x) + H(y|x) + 2872. 106 | 107 | The 2872-bit prefix gamma proves this. 108 | 109 | Gamma does the job, but it's slow. 110 | So below we will present delta, which is a greatly 111 | sped up version of gamma. The speed up is 112 | achieved by introducing a new primitive function 113 | to do the job. The was-read mechanism used below 114 | is much faster than our technique here using try 115 | to get the bits of the program p = x* as we run it. 116 | ] 117 | 118 | define gamma 119 | 120 | [read program p bit by bit until we get it all] 121 | 122 | let (loop p) 123 | if = success car try no-time-limit 'eval read-exp p 124 | [then] p 125 | [else] (loop append p cons read-bit nil) 126 | 127 | let x* (loop nil) [get x* = program for x] 128 | let x run-utm-on x* [get x from x*] 129 | let y [get y from x* by running] 130 | eval cons 'read-exp [((read-exp) (' x*))] 131 | cons cons "' 132 | cons x* 133 | nil 134 | nil 135 | 136 | [form the pair x, y] 137 | cons x cons y nil 138 | [Size it.] 139 | length bits gamma 140 | [Use it.] 141 | 142 | run-utm-on 143 | 144 | [get pair x, y by combining ] 145 | [a program for x and a program to get y from x] 146 | 147 | append 148 | 149 | bits gamma 150 | 151 | append 152 | 153 | [x* = program to calculate x = 2] 154 | [[Supposedly x* is smallest possible,]] 155 | [[but this works for ANY x* for x.]] 156 | 157 | bits' + 1 1 158 | 159 | [program to calculate y = x+1 from x*] 160 | 161 | bits' lambda(x*) + 1 run-utm-on x* 162 | [ 163 | This technique for getting a program as well as its output 164 | by inching along using try is slow. 165 | 166 | Now let's speed up gamma by adding a new primitive function. 167 | Was-read gives the binary data read so far in the current try. 168 | With it we will prove that H(x,y) <= H(x) + H(y|x) + 2104. 169 | ] 170 | define delta [knows that its own size is 2104 bits] 171 | let (skip n s) [skip first n bits of bit string s] 172 | if = n 0 s (skip - n 1 cdr s) [used to erase delta from was-read] 173 | let x eval read-exp [get x] 174 | let x* (skip 2104 was-read) [get program for x] 175 | let y [calculate y from the program for x by] 176 | eval cons 'read-exp [running ((read-exp) (' x*))] 177 | cons cons "' 178 | cons x* 179 | nil 180 | nil 181 | [form the pair x, y] 182 | cons x cons y nil 183 | [Size it.] 184 | length bits delta 185 | [Use it.] 186 | 187 | run-utm-on 188 | 189 | [get pair x, y by combining ] 190 | [a program for x and a program to get y from x] 191 | 192 | append 193 | 194 | bits delta 195 | 196 | append 197 | 198 | [x* = program to calculate x = 2] 199 | [[Supposedly x* is smallest possible,]] 200 | [[but this works for ANY x* for x.]] 201 | 202 | bits' + 1 1 203 | 204 | [program to calculate y = x+1 from x*] 205 | 206 | bits' lambda(x*) + 1 run-utm-on x* 207 | -------------------------------------------------------------------------------- /book-examples/chaitin2.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Solovay random 3 | iff it is strong Chaitin random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [Second part: not Ch random ===> not Sol random] 16 | 17 | define (is-in? x l) [is x an element of list l?] 18 | if atom l false 19 | if = x car l true 20 | (is-in? x cdr l) 21 | 22 | define is-in? 23 | value (lambda (x l) (if (atom l) false (if (= x (car l)) 24 | true (is-in? x (cdr l))))) 25 | 26 | define (union x y) [set-theoretic union of two sets x y] 27 | if atom x y 28 | if (is-in? car x y) (union cdr x y) 29 | cons car x (union cdr x y) 30 | 31 | define union 32 | value (lambda (x y) (if (atom x) y (if (is-in? (car x) y 33 | ) (union (cdr x) y) (cons (car x) (union (cdr x) y 34 | ))))) 35 | 36 | define (is-bit-string? x) [is x a list of 0's and 1's?] 37 | if = x nil true 38 | if atom x false 39 | if = 0 car x (is-bit-string? cdr x) 40 | if = 1 car x (is-bit-string? cdr x) 41 | false 42 | 43 | define is-bit-string? 44 | value (lambda (x) (if (= x nil) true (if (atom x) false 45 | (if (= 0 (car x)) (is-bit-string? (cdr x)) (if (= 46 | 1 (car x)) (is-bit-string? (cdr x)) false))))) 47 | 48 | define C [test computer---real thing is eval read-exp] 49 | let (loop x y) [xx yy zz 01 ===> xyz] 50 | if = x y cons x (loop read-bit read-bit) 51 | nil 52 | (loop read-bit read-bit) 53 | 54 | define C 55 | value ((' (lambda (loop) (loop (read-bit) (read-bit)))) 56 | (' (lambda (x y) (if (= x y) (cons x (loop (read-b 57 | it) (read-bit))) nil)))) 58 | 59 | [ 60 | The hypothesis that 61 | the real number r is not Chaitin random 62 | means that there is a K such that 63 | for infinitely many values of n 64 | H(r_n) < n + K, 65 | where r_n is the first n bits of r. 66 | 67 | For this example, let's suppose that K = 5. 68 | ] 69 | 70 | define K 5 71 | 72 | define K 73 | value 5 74 | 75 | [ 76 | Our proof depends on the fact that there is a c such that 77 | the probability that an n-bit string s has 78 | H(s) < n + K 79 | is less than 2^{-H(n) + K + c}. 80 | ] 81 | 82 | [ 83 | Now let's do stage N of A_n = n-bit strings s with H(s) < |s| + K. 84 | At stage N we look at all programs p less than n + K bits in size for time up to N. 85 | ] 86 | 87 | define (quasi-compressible N n) 88 | (look-at nil) 89 | 90 | define quasi-compressible 91 | value (lambda (N n) (look-at nil)) 92 | 93 | [this routine has free parameters N, n, K, C] 94 | 95 | define (look-at p) [produces quasi-compressible strings of length n] 96 | if = length p + n K [p too long?] 97 | nil 98 | let v try N C ['eval read-exp] p 99 | if = success car v 100 | let w cadr v 101 | if (is-bit-string? w) 102 | if = n length w 103 | cons w nil 104 | nil 105 | nil 106 | [ 107 | Also works with append below instead of union 108 | because duplicates are removed later by (process interval). 109 | ] 110 | (union (look-at append p cons 0 nil) 111 | (look-at append p cons 1 nil)) 112 | 113 | define look-at 114 | value (lambda (p) (if (= (length p) (+ n K)) nil ((' (la 115 | mbda (v) (if (= success (car v)) ((' (lambda (w) ( 116 | if (is-bit-string? w) (if (= n (length w)) (cons w 117 | nil) nil) nil))) (car (cdr v))) (union (look-at ( 118 | append p (cons 0 nil))) (look-at (append p (cons 1 119 | nil))))))) (try N C p)))) 120 | 121 | [ 122 | List of intervals in covering so far. 123 | used to avoid overlapping intervals in covering. 124 | 125 | This is easy to do because here because 126 | all intervals are the same length. 127 | ] 128 | define intervals () 129 | 130 | define intervals 131 | value () 132 | 133 | define (process-all x) [process list of intervals x] 134 | if atom x intervals 135 | let intervals append (process car x) intervals 136 | (process-all cdr x) 137 | 138 | define process-all 139 | value (lambda (x) (if (atom x) intervals ((' (lambda (in 140 | tervals) (process-all (cdr x)))) (append (process 141 | (car x)) intervals)))) 142 | 143 | define (process interval) [process individual interval] 144 | if (is-in? interval intervals) 145 | [then don't need to repeat it] 146 | nil 147 | [else interval is fine as is] 148 | cons display interval nil 149 | 150 | define process 151 | value (lambda (interval) (if (is-in? interval intervals) 152 | nil (cons (display interval) nil))) 153 | 154 | [ 155 | Put it all together---Here is cover A_n 156 | covering all reals r having n-bit prefix r_n 157 | with H(r_n) < n + K. 158 | 159 | And we have measure \mu A_n <= 2^{-H(n)+K+c} 160 | so that Sum_n \mu A_n <= \Omega 2^{K+c} <= 2^{K+c} < infinity . 161 | 162 | Hence a real r which is not strongly Chaitin random 163 | will be in infinitely many of the A_n, 164 | which have convergent total measure, 165 | and hence will not be Solovay random. 166 | ] 167 | define (A n) 168 | let intervals nil 169 | let (stage N) 170 | if = N 7 stop! [to stop test run---remove if real thing] 171 | let quasi-compressible-strings (quasi-compressible N n) 172 | let intervals (process-all quasi-compressible-strings) 173 | (stage + 1 N) 174 | [go!!!!!] 175 | (stage 0) 176 | 177 | define A 178 | value (lambda (n) ((' (lambda (intervals) ((' (lambda (s 179 | tage) (stage 0))) (' (lambda (N) (if (= N 7) stop! 180 | ((' (lambda (quasi-compressible-strings) ((' (lam 181 | bda (intervals) (stage (+ 1 N)))) (process-all qua 182 | si-compressible-strings)))) (quasi-compressible N 183 | n)))))))) nil)) 184 | 185 | [n = 2, i.e., quasi-compressible 2-bit strings] 186 | (A 2) 187 | 188 | expression (A 2) 189 | display (0 0) 190 | display (0 1) 191 | display (1 0) 192 | display (1 1) 193 | value stop! 194 | -------------------------------------------------------------------------------- /book-examples/sets.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[[ 4 | 5 | Elementary Set Theory in LISP (finite sets) 6 | 7 | ]]]]] 8 | 9 | [Set membership predicate:] 10 | 11 | define (member? e[lement] set) 12 | [Is set empty?] 13 | if atom set [then] false [else] 14 | [Is the element that we are looking for the first element?] 15 | if = e car set [then] true [else] 16 | [recursion step!] 17 | [return] (member? e cdr set) 18 | 19 | define member? 20 | value (lambda (e set) (if (atom set) false (if (= e (car 21 | set)) true (member? e (cdr set))))) 22 | 23 | 24 | (member? 1 '(1 2 3)) 25 | 26 | expression (member? 1 (' (1 2 3))) 27 | value true 28 | 29 | (member? 4 '(1 2 3)) 30 | 31 | expression (member? 4 (' (1 2 3))) 32 | value false 33 | 34 | 35 | [Subset predicate:] 36 | 37 | define (subset? set1 set2) 38 | [Is the first set empty?] 39 | if atom set1 [then] true [else] 40 | [Is the first element of the first set in the second set?] 41 | if (member? car set1 set2) 42 | [then] [recursion!] (subset? cdr set1 set2) 43 | [else] false 44 | 45 | define subset? 46 | value (lambda (set1 set2) (if (atom set1) true (if (memb 47 | er? (car set1) set2) (subset? (cdr set1) set2) fal 48 | se))) 49 | 50 | 51 | (subset? '(1 2) '(1 2 3)) 52 | 53 | expression (subset? (' (1 2)) (' (1 2 3))) 54 | value true 55 | 56 | (subset? '(1 4) '(1 2 3)) 57 | 58 | expression (subset? (' (1 4)) (' (1 2 3))) 59 | value false 60 | 61 | 62 | [Set union:] 63 | 64 | define (union x y) 65 | [Is the first set empty?] 66 | if atom x [then] [return] y [else] 67 | [Is the first element of the first set in the second set?] 68 | if (member? car x y) 69 | [then] [return] (union cdr x y) 70 | [else] [return] cons car x (union cdr x y) 71 | 72 | define union 73 | value (lambda (x y) (if (atom x) y (if (member? (car x) 74 | y) (union (cdr x) y) (cons (car x) (union (cdr x) 75 | y))))) 76 | 77 | 78 | (union '(1 2 3) '(2 3 4)) 79 | 80 | expression (union (' (1 2 3)) (' (2 3 4))) 81 | value (1 2 3 4) 82 | 83 | 84 | [Union of a list of sets:] 85 | 86 | define (unionl l) if atom l nil (union car l (unionl cdr l)) 87 | 88 | define unionl 89 | value (lambda (l) (if (atom l) nil (union (car l) (union 90 | l (cdr l))))) 91 | 92 | 93 | (unionl '((1 2) (2 3) (3 4))) 94 | 95 | expression (unionl (' ((1 2) (2 3) (3 4)))) 96 | value (1 2 3 4) 97 | 98 | 99 | [Set intersection:] 100 | 101 | define (intersection x y) 102 | [Is the first set empty?] 103 | if atom x [then] [return] nil [empty set] [else] 104 | [Is the first element of the first set in the second set?] 105 | if (member? car x y) 106 | [then] [return] cons car x (intersection cdr x y) 107 | [else] [return] (intersection cdr x y) 108 | 109 | define intersection 110 | value (lambda (x y) (if (atom x) nil (if (member? (car x 111 | ) y) (cons (car x) (intersection (cdr x) y)) (inte 112 | rsection (cdr x) y)))) 113 | 114 | 115 | (intersection '(1 2 3) '(2 3 4)) 116 | 117 | expression (intersection (' (1 2 3)) (' (2 3 4))) 118 | value (2 3) 119 | 120 | 121 | [Relative complement of two sets x and y = x - y:] 122 | 123 | define (complement x y) 124 | [Is the first set empty?] 125 | if atom x [then] [return] nil [empty set] [else] 126 | [Is the first element of the first set in the second set?] 127 | if (member? car x y) 128 | [then] [return] (complement cdr x y) 129 | [else] [return] cons car x (complement cdr x y) 130 | 131 | define complement 132 | value (lambda (x y) (if (atom x) nil (if (member? (car x 133 | ) y) (complement (cdr x) y) (cons (car x) (complem 134 | ent (cdr x) y))))) 135 | 136 | 137 | (complement '(1 2 3) '(2 3 4)) 138 | 139 | expression (complement (' (1 2 3)) (' (2 3 4))) 140 | value (1) 141 | 142 | 143 | 144 | [Cartesian product of an element with a list:] 145 | 146 | define (product1 e y) 147 | if atom y 148 | [then] nil 149 | [else] cons cons e cons car y nil (product1 e cdr y) 150 | 151 | define product1 152 | value (lambda (e y) (if (atom y) nil (cons (cons e (cons 153 | (car y) nil)) (product1 e (cdr y))))) 154 | 155 | 156 | (product1 3 '(4 5 6)) 157 | 158 | expression (product1 3 (' (4 5 6))) 159 | value ((3 4) (3 5) (3 6)) 160 | 161 | 162 | [Cartesian product of two sets = set of ordered pairs:] 163 | 164 | define (product x y) 165 | [Is the first set empty?] 166 | if atom x [then] [return] nil [empty set] [else] 167 | [return] (union (product1 car x y) (product cdr x y)) 168 | 169 | define product 170 | value (lambda (x y) (if (atom x) nil (union (product1 (c 171 | ar x) y) (product (cdr x) y)))) 172 | 173 | 174 | (product '(1 2 3) '(x y z)) 175 | 176 | expression (product (' (1 2 3)) (' (x y z))) 177 | value ((1 x) (1 y) (1 z) (2 x) (2 y) (2 z) (3 x) (3 y) ( 178 | 3 z)) 179 | 180 | 181 | [Product of an element with a list of sets:] 182 | 183 | define (product2 e y) 184 | if atom y 185 | [then] nil 186 | [else] cons cons e car y (product2 e cdr y) 187 | 188 | define product2 189 | value (lambda (e y) (if (atom y) nil (cons (cons e (car 190 | y)) (product2 e (cdr y))))) 191 | 192 | 193 | (product2 3 '((4 5) (5 6) (6 7))) 194 | 195 | expression (product2 3 (' ((4 5) (5 6) (6 7)))) 196 | value ((3 4 5) (3 5 6) (3 6 7)) 197 | 198 | 199 | [Set of all subsets of a given set:] 200 | 201 | define (subsets x) 202 | if atom x 203 | [then] '(()) [else] 204 | let y [be] (subsets cdr x) [in] 205 | (union y (product2 car x y)) 206 | 207 | define subsets 208 | value (lambda (x) (if (atom x) (' (())) ((' (lambda (y) 209 | (union y (product2 (car x) y)))) (subsets (cdr x)) 210 | ))) 211 | 212 | 213 | (subsets '(1 2 3)) 214 | 215 | expression (subsets (' (1 2 3))) 216 | value (() (3) (2) (2 3) (1) (1 3) (1 2) (1 2 3)) 217 | 218 | length (subsets '(1 2 3)) 219 | 220 | expression (length (subsets (' (1 2 3)))) 221 | value 8 222 | 223 | (subsets '(1 2 3 4)) 224 | 225 | expression (subsets (' (1 2 3 4))) 226 | value (() (4) (3) (3 4) (2) (2 4) (2 3) (2 3 4) (1) (1 4 227 | ) (1 3) (1 3 4) (1 2) (1 2 4) (1 2 3) (1 2 3 4)) 228 | 229 | length (subsets '(1 2 3 4)) 230 | 231 | expression (length (subsets (' (1 2 3 4)))) 232 | value 16 233 | 234 | End of LISP Run 235 | 236 | Elapsed time is 0 seconds. 237 | -------------------------------------------------------------------------------- /book-examples/examples.l: -------------------------------------------------------------------------------- 1 | [ Test new lisp & show how it works ] 2 | 3 | aa [ initially all atoms eval to self ] 4 | nil [ except nil = the empty list ] 5 | 'aa [ quote = literally ] 6 | '(aa bb cc) [ delimiters are ' " ( ) [ ] blank \n ] 7 | (aa bb cc) [ what if quote omitted?! ] 8 | 'car '(aa bb cc) [ here effect is different ] 9 | car '(aa bb cc) [ car = first element of list ] 10 | car '((a b)c d) 11 | car '(aa) 12 | car aa [ ignore error ] 13 | cdr '(aa bb cc) [ cdr = rest of list ] 14 | cdr '((a b)c d) 15 | cdr '(aa) 16 | cdr aa [ ignore error ] 17 | cadr '(aa bb cc) [ combinations of car & cdr ] 18 | caddr '(aa bb cc) 19 | cons 'aa '(bb cc) [ cons = inverse of car & cdr ] 20 | cons'(a b)'(c d) 21 | cons aa nil 22 | cons aa () 23 | cons aa bb [ ignore error ] 24 | ("cons aa) [ supply nil for missing arguments ] 25 | ("cons '(aa) '(bb) '(cc)) [ ignore extra arguments ] 26 | atom ' aa [ is-atomic? predicate ] 27 | atom '(aa) 28 | atom '( ) 29 | = aa bb [ are-equal-S-expressions? predicate ] 30 | = aa aa 31 | = '(a b)'(a b) 32 | = '(a b)'(a x) 33 | if true x y [ if ... then ... else ... ] 34 | if false x y 35 | if xxx x y [ anything not false is true ] 36 | [ display intermediate results ] 37 | cdr display cdr display cdr display '( a b c d e ) 38 | ('lambda(x y)x 1 2) [ lambda expression ] 39 | ('lambda(x y)y 1 2) 40 | ('lambda(x y)cons y cons x nil 1 2) 41 | (if true "car "cdr '(a b c)) [ function expressions ] 42 | (if false "car "cdr '(a b c)) 43 | ('lambda()cons x cons y nil) [ function with no arguments ] 44 | [ Here is a way to create an expression and then 45 | evaluate it in the current environment. EVAL (see 46 | below) does this using a clean environment instead. ] 47 | (display 48 | cons "lambda cons nil cons display 'cons x cons y nil nil) 49 | [ let ... be ... in ... ] 50 | 51 | let x a cons x cons x nil [ first case, let x be ... in ... ] 52 | x 53 | [ second case, let (f x) be ... in ... ] 54 | 55 | let (f x) if atom display x x (f car x) 56 | (f '(((a)b)c)) 57 | f 58 | append '(a b c) '(d e f) [ concatenate-list primitive ] 59 | [ define "by hand" temporarily ] 60 | 61 | let (cat x y) if atom x y cons car x (cat cdr x y) 62 | (cat '(a b c) '(d e f)) 63 | cat 64 | [ define "by hand" permanently ] 65 | 66 | define (cat x y) if atom x y cons car x (cat cdr x y) 67 | cat 68 | (cat '(a b c) '(d e f)) 69 | define x (a b c) [ define atom, not function ] 70 | cons x nil 71 | define x (d e f) 72 | cons x nil 73 | size abc [ size of S-expression in characters ] 74 | size ' ( a b c ) 75 | length ' ( a b c ) [ number of elements in list ] 76 | length display bits ' a [ S-expression --> bits ] 77 | length display bits ' abc [ extra character is \n ] 78 | length display bits nil 79 | length display bits ' (a) 80 | [ plus ] 81 | + abc 15 [ not number --> 0 ] 82 | + '(abc) 15 83 | + 10 15 84 | - 10 15 [ non-negative minus ] 85 | - 15 10 86 | * 10 15 [ times ] 87 | ^ 10 15 [ power ] 88 | < 10 15 [ less than ] 89 | < 10 10 90 | > 15 10 [ greater than ] 91 | > 10 10 92 | <= 15 10 [ less than or equal ] 93 | <= 10 10 94 | >= 10 15 [ greater than or equal ] 95 | >= 10 10 96 | = 10 15 [ equal ] 97 | = 10 10 98 | [ here not number isn't considered zero ] 99 | = abc 0 100 | = 0003 3 [ other ways numbers are funny ] 101 | 000099 [ leading zeros removed ] 102 | [ and numbers are constants ] 103 | let x b cons x cons x nil 104 | let 99 45 cons 99 cons 99 nil 105 | define 99 45 106 | cons 99 cons 99 nil 107 | [ decimal<-->binary conversions ] 108 | 109 | base10-to-2 255 110 | base10-to-2 256 111 | base10-to-2 257 112 | base2-to-10 '(1 1 1 1) 113 | base2-to-10 '(1 0 0 0 0) 114 | base2-to-10 '(1 0 0 0 1) 115 | [ illustrate eval & try ] 116 | 117 | eval display '+ display 5 display 15 118 | try 0 display '+ display 5 display 15 nil 119 | try 0 display '+ debug 5 debug 15 nil 120 | [ eval & try use initial variable bindings ] 121 | 122 | cons x nil 123 | eval 'cons x nil 124 | try 0 'cons x nil nil 125 | define five! [ to illustrate time limits ] 126 | let (f x) if = display x 0 1 * x (f - x 1) 127 | (f 5) 128 | eval five! 129 | [ by the way, numbers can be big: ] 130 | let (f x) if = x 0 1 * x (f - x 1) 131 | (f 100) [ one hundred factorial! ] 132 | [ time limit is nesting depth of re-evaluations 133 | due to function calls & eval & try ] 134 | 135 | try 0 five! nil 136 | try 1 five! nil 137 | try 2 five! nil 138 | try 3 five! nil 139 | try 4 five! nil 140 | try 5 five! nil 141 | try 6 five! nil 142 | try 7 five! nil 143 | try no-time-limit five! nil 144 | define two* [ to illustrate running out of data ] 145 | let (f x) if = 0 x nil 146 | cons * 2 display read-bit (f - x 1) 147 | (f 5) 148 | try 6 two* '(1 0 1 0 1) 149 | try 7 two* '(1 0 1 0 1) 150 | try 7 two* '(1 0 1) 151 | try no-time-limit two* '(1 0 1) 152 | try 18 153 | 'let (f x) if = 0 x nil 154 | cons * 2 display read-bit (f - x 1) 155 | (f 16) 156 | bits 'a 157 | [ illustrate nested try's ] 158 | [ most constraining limit wins ] 159 | 160 | try 20 161 | 'cons abcdef try 10 162 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 163 | nil nil 164 | try 10 165 | 'cons abcdef try 20 166 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 167 | nil nil 168 | try 10 169 | 'cons abcdef try 20 170 | 'let (f n) (f debug + n 1) (f 0) [infinite loop] 171 | nil nil 172 | try no-time-limit 173 | 'cons abcdef try 20 174 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 175 | nil nil 176 | try 10 177 | 'cons abcdef try no-time-limit 178 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 179 | nil nil 180 | [ illustrate read-bit & read-exp ] 181 | 182 | read-bit 183 | read-exp 184 | try 0 'read-bit nil 185 | try 0 'read-exp nil 186 | try 0 'read-exp bits 'abc 187 | try 0 'read-exp bits '(abc def) 188 | try 0 'read-exp bits '(abc(def ghi)jkl) 189 | try 0 'cons read-exp cons read-bit nil bits 'abc 190 | try 0 'cons read-exp cons read-bit nil append bits 'abc '(0) 191 | try 0 'cons read-exp cons read-bit nil append bits 'abc '(1) 192 | try 0 'read-exp bits '(a b c) 193 | try 0 'cons read-exp cons read-exp nil bits '(a b c) 194 | try 0 'cons read-exp cons read-exp nil 195 | append bits '(a b c) bits '(d e f) 196 | bits 'a [ to get characters codes ] 197 | try 0 'read-exp '(0 1 1 0 0 0 0 1) ['a' but no \n character] 198 | try 0 'read-exp '(0 1 1 0 0 0 0 1 0 0 0 0 1 0 1)[0 missing] 199 | try 0 'read-exp '(0 1 1 0 0 0 0 1 0 0 0 0 1 0 1 0) [okay] 200 | [ if we get to \n reading 8 bits at a time, 201 | we will always interpret as a valid S-expression ] 202 | try 0 'read-exp 203 | '(0 0 0 0 1 0 1 0) [nothing in record; only \n] 204 | try 0 'read-exp '(1 1 1 1 1 1 1 1 [unprintable character] 205 | 0 0 0 0 1 0 1 0) [is deleted] 206 | bits () [ to get characters codes ] 207 | [ three left parentheses==>three right parentheses supplied ] 208 | try 0 'read-exp '(0 0 1 0 1 0 0 0 0 0 1 0 1 0 0 0 209 | 0 0 1 0 1 0 0 0 0 0 0 0 1 0 1 0) 210 | [ right parenthesis 'a'==>left parenthesis supplied ] 211 | try 0 'read-exp '(0 0 1 0 1 0 0 1 0 1 1 0 0 0 0 1 212 | 0 0 0 0 1 0 1 0) [ & extra 'a' ignored ] 213 | [ 'a' right parenthesis==>'a' is seen & parenthesis ] 214 | try 0 'read-exp '(0 1 1 0 0 0 0 1 0 0 1 0 1 0 0 1 215 | 0 0 0 0 1 0 1 0) [ is ignored ] 216 | -------------------------------------------------------------------------------- /book-examples/kraft.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | KRAFT INEQUALITY CRITERION FOR CONSTRUCTING COMPUTERS 3 | Take as input requirement pairs (output, size of program) 4 | and produce as output assignment pairs (program, output). 5 | 6 | We assume that the requirements are consistent. 7 | I.e. the sum of 1/2 raised to each size is <= unity. 8 | Then we can produce a set of assignments that meets 9 | the requirements and is prefex free, i.e. no extension 10 | of a valid program is a valid program. 11 | 12 | The basic data structure in this program is the free space pool. 13 | That's a list of prefixes all of whose extensions (by zero 14 | or more bits) are unassigned programs. Initially this is the 15 | list consisting of the empty string because everything is free. 16 | 17 | The algorithm consists of assigning that program that meets 18 | each requirement that is available and that comes first in 19 | lexicographic order (0 before 1). 20 | 21 | The free space pool is kept in lexicographic order, to facilitate 22 | searching. So the algorithm is to look for the first prefix in 23 | the pool that is <= the requested size in each requirement. 24 | 25 | If it has exactly the requested size, then that prefix is the 26 | program assigned to the output in the requirement. If not, 27 | the prefix must be smaller than the requirement, and represents 28 | a piece of free storage that is a power of two larger than needed. 29 | So as program we assign the prefix extended by sufficiently many 30 | 0's to reach the requested size, and then the prefix is replaced 31 | in the free space pool by prefix00001, prefix0001, prefix001, 32 | prefix01, prefix1, for all sizes up to the assigned size. 33 | This will always work if the Kraft inequality is satisfied. 34 | 35 | If this algorithm is given the requirements 36 | (0 1) (1 2) (2 3) (3 4)... 37 | (i.e., a 1-bit p for 0, a 2-bit p for 1, a 3-bit p for 2, etc.) 38 | it will produce the assignments 39 | (0 0) (10 1) (110 2) (1110 3)... 40 | (i.e., p = 0 yields 0, p = 10 yields 1, p = 110 yields 2, etc.) 41 | In this case the free storage pool will always consist of a 42 | single piece. 43 | 44 | Key fact: if you follow this first-fit algorithm, the free space 45 | will appear in blocks in the unit interval whose sizes are all 46 | distinct powers of two, and in order of increasing size. So 47 | if an allocation cannot be made, the piece requested must be 48 | larger (at least twice as large) as the last & largest piece. 49 | But the total free storage is less than twice the size of the 50 | last & largest free piece, so allocating this would have violated 51 | the Kraft inequality. 52 | 53 | To actually run these programs, we have to feed the output of 54 | this program kraft.l into the previous one, exec.l. 55 | So there will in fact be an additional prefix in front of the 56 | assigned programs to tell U how to do kraft.l and how to do exec.l. 57 | 58 | Kraft is written as a function that is applied to a finite list 59 | of requirements and produces the corresponding finite list of 60 | assignments. Exec.l will use try to run the requirement generator 61 | for more and more time to produce longer and longer lists of 62 | assignments. It will then use the Kraft function to transform 63 | these into longer and longer lists of assignments, which it will 64 | use to actually run individual programs by reading them bit by 65 | bit as required. The Kraft function has the property that applying 66 | it to a longer list of requirements just produces a longer list 67 | of assignments. I.e., it's monotone, it never changes its mind. 68 | ]]]]] 69 | 70 | [used to assign a program to an output] 71 | 72 | define (extend-with-0s bit-string [to] given-length) 73 | if = length bit-string given-length [then] 74 | bit-string [else] 75 | append (extend-with-0s bit-string [to] - given-length 1) 76 | cons 0 nil 77 | [test it] 78 | 79 | (extend-with-0s '(1 1 1) [to] 6) 80 | (extend-with-0s '(1 1 1) [to] 5) 81 | (extend-with-0s '(1 1 1) [to] 4) 82 | (extend-with-0s '(1 1 1) [to] 3) 83 | [used to subtract storage from a piece of free storage] 84 | 85 | define (remove-piece free-prefix size-of-program) 86 | if = size-of-program length free-prefix 87 | nil [then no storage left, else] 88 | cons append (extend-with-0s free-prefix [to] - size-of-program 1) 89 | cons 1 nil 90 | (remove-piece free-prefix - size-of-program 1) 91 | [test it] 92 | 93 | (remove-piece '(1 1 1) 6) 94 | (remove-piece '(1 1 1) 5) 95 | (remove-piece '(1 1 1) 4) 96 | (remove-piece '(1 1 1) 3) 97 | [ 98 | Make-assignments uses debug to show us the 99 | free-space-pool after making each assignment. 100 | If an assignment cannot be made because 101 | there is not enough storage, we just skip it. 102 | ] 103 | define (make-assignments free-space-pool requirements) 104 | 105 | let free-space-pool debug free-space-pool 106 | [Done just to show pool!] 107 | 108 | if atom requirements nil [no requirements => no assignments] 109 | [If so, we're finished!] 110 | 111 | let requirement car requirements 112 | let requirements cdr requirements 113 | let output-of-program car requirement 114 | let size-of-program cadr requirement 115 | let already-scanned nil 116 | let not-yet-scanned free-space-pool 117 | 118 | let (loop-thru-free-space-pool) [DEFINE IT!] 119 | 120 | if atom not-yet-scanned [cannot make this assignment!] 121 | [indicate problem and go to next requirement] 122 | cons not-enough-storage! 123 | (make-assignments free-space-pool requirements) 124 | 125 | let free-prefix car not-yet-scanned 126 | let not-yet-scanned cdr not-yet-scanned 127 | if < size-of-program length free-prefix 128 | 129 | [doesn't fit --- continue scanning] 130 | let already-scanned 131 | append already-scanned 132 | cons free-prefix nil 133 | (loop-thru-free-space-pool) 134 | 135 | [fits! --- make assignment] 136 | [add to list of rest of assignments] 137 | let free-space-pool 138 | append already-scanned 139 | append (remove-piece free-prefix size-of-program) 140 | not-yet-scanned 141 | 142 | let assignment 143 | [make assignment - add to list of rest of assignments] 144 | [found free piece where it fits!] 145 | [extend with zeros to correct size] 146 | cons (extend-with-0s free-prefix [to] size-of-program) 147 | cons output-of-program 148 | nil 149 | 150 | [return full list of assignments] 151 | cons assignment 152 | (make-assignments free-space-pool requirements) 153 | 154 | [NOW DO IT!] 155 | (loop-thru-free-space-pool) 156 | [put it all together] 157 | 158 | define (kraft requirements) 159 | 160 | let free-space-pool '(()) [everything free] 161 | 162 | (make-assignments free-space-pool requirements) 163 | [TEST KRAFT!] 164 | 165 | (kraft '((x 0) (y 1))) 166 | (kraft '((a 1) (b 0) (c 1))) 167 | (kraft '((x 1) (y 2))) 168 | (kraft '((a 1) (b 2) (c 3) (d 4) (e 5))) 169 | (kraft '((e 5) (d 4) (c 3) (b 2) (a 1))) 170 | (kraft '((e 5) (c 3) (d 4) (a 1) (b 2))) 171 | -------------------------------------------------------------------------------- /book-examples/occam.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Occam's razor---Concentration process. 3 | From computer C construct C' such that 4 | if P_C(x) >= 1/2^k, then 5 | then C' has a k+1 bit program for x. 6 | Hence H(x) <= -log_2 P_C(x) + c 7 | where c depends only on C, not on x. 8 | ]]]]] 9 | 10 | define all-together 11 | 12 | [this is used to avoid duplicate requirements for C'] 13 | let previous-requirements nil 14 | 15 | [test case special-purpose computer C:] 16 | [ignores odd bits, multiplies by ten until hits a 1] 17 | [this C has many programs that do the same job!] 18 | [[to put U here instead, let C be 'eval read-exp]] 19 | let C ' 20 | let (loop n) 21 | let ignore-it [be] read-bit [skip bit] 22 | if = 1 read-bit [then return] n 23 | [else] (loop * 10 n) 24 | (loop 10) 25 | 26 | [stage n = 0, 1, 2, ... of overall concentration process] 27 | [look at all n-bit programs for C, run them for time n] 28 | [merge (output,multiplicity) pairs, emit requirements for C'] 29 | let (stage n) 30 | let previous-requirements 31 | (make-requirements debug (how-many? nil debug n)) 32 | (stage + n 1) 33 | 34 | [produce (output,multiplicity) pairs] 35 | [by running all n-bit programs on C for time n] 36 | let (how-many? p n) 37 | if = n length p 38 | 39 | [run program p for time n] 40 | let v try n [U => 'eval read-exp] C p 41 | if = success car v 42 | 43 | [program ran to completion] 44 | [indicate that it produces] 45 | [its output with multiplicity one] 46 | cons cons cadr v cons 1 nil 47 | nil 48 | 49 | [otherwise program failed] 50 | nil 51 | [empty list of (output,multiplicity) pairs] 52 | 53 | [otherwise use recursion to combine multiplicities] 54 | (merge (how-many? cons 0 p n) 55 | (how-many? cons 1 p n) 56 | ) 57 | 58 | [add one (output,multiplicity) pair to a list of such pairs] 59 | let (merge1 pair list) 60 | if atom list cons pair nil 61 | let first-in-list car list 62 | let rest-of-list cdr list 63 | let output car pair 64 | let multiplicity cadr pair 65 | let output2 car first-in-list 66 | let multiplicity2 cadr first-in-list 67 | if = output output2 68 | [= -> combine multiplicities] 69 | cons cons output cons + multiplicity multiplicity2 nil 70 | rest-of-list 71 | [!= -> don't combine multiplicities] 72 | cons first-in-list 73 | (merge1 pair rest-of-list) 74 | 75 | [combine two lists of (output,multiplicity) pairs] 76 | let (merge list list2) 77 | if atom list list2 78 | (merge1 car list (merge cdr list list2)) 79 | 80 | [exponent in highest power of 2 <= n, n != 0] 81 | let (log2 n) 82 | let (loop power exponent) 83 | let new-power + power power [double it] 84 | let new-exponent + 1 exponent [add 1 to it] 85 | if > new-power n [then return] exponent 86 | [else] (loop new-power new-exponent) 87 | (loop [initial power of two] 1 [initial exponent of 2] 0) 88 | 89 | let (make-requirements list-of-pairs) 90 | if atom list-of-pairs previous-requirements 91 | let first-pair car list-of-pairs 92 | let list-of-pairs cdr list-of-pairs 93 | let output car first-pair 94 | let multiplicity cadr first-pair 95 | let kraft-requirement 96 | cons output cons - + n 1 (log2 multiplicity) nil 97 | let previous-requirements (make-requirements list-of-pairs) 98 | [keep only first appearance of requirement] 99 | if (is-in? kraft-requirement previous-requirements) 100 | previous-requirements 101 | cons debug display kraft-requirement previous-requirements 102 | 103 | let (is-in? x list) [is x in list?] 104 | if atom list false 105 | if = x car list true 106 | (is-in? x cdr list) 107 | 108 | [HERE GOES!] 109 | (stage 0) 110 | 111 | define all-together 112 | value ((' (lambda (previous-requirements) ((' (lambda (C 113 | ) ((' (lambda (stage) ((' (lambda (how-many?) ((' 114 | (lambda (merge1) ((' (lambda (merge) ((' (lambda ( 115 | log2) ((' (lambda (make-requirements) ((' (lambda 116 | (is-in?) (stage 0))) (' (lambda (x list) (if (atom 117 | list) false (if (= x (car list)) true (is-in? x ( 118 | cdr list))))))))) (' (lambda (list-of-pairs) (if ( 119 | atom list-of-pairs) previous-requirements ((' (lam 120 | bda (first-pair) ((' (lambda (list-of-pairs) ((' ( 121 | lambda (output) ((' (lambda (multiplicity) ((' (la 122 | mbda (kraft-requirement) ((' (lambda (previous-req 123 | uirements) (if (is-in? kraft-requirement previous- 124 | requirements) previous-requirements (cons (debug ( 125 | display kraft-requirement)) previous-requirements) 126 | ))) (make-requirements list-of-pairs)))) (cons out 127 | put (cons (- (+ n 1) (log2 multiplicity)) nil))))) 128 | (car (cdr first-pair))))) (car first-pair)))) (cd 129 | r list-of-pairs)))) (car list-of-pairs)))))))) (' 130 | (lambda (n) ((' (lambda (loop) (loop 1 0))) (' (la 131 | mbda (power exponent) ((' (lambda (new-power) ((' 132 | (lambda (new-exponent) (if (> new-power n) exponen 133 | t (loop new-power new-exponent)))) (+ 1 exponent)) 134 | )) (+ power power)))))))))) (' (lambda (list list2 135 | ) (if (atom list) list2 (merge1 (car list) (merge 136 | (cdr list) list2)))))))) (' (lambda (pair list) (i 137 | f (atom list) (cons pair nil) ((' (lambda (first-i 138 | n-list) ((' (lambda (rest-of-list) ((' (lambda (ou 139 | tput) ((' (lambda (multiplicity) ((' (lambda (outp 140 | ut2) ((' (lambda (multiplicity2) (if (= output out 141 | put2) (cons (cons output (cons (+ multiplicity mul 142 | tiplicity2) nil)) rest-of-list) (cons first-in-lis 143 | t (merge1 pair rest-of-list))))) (car (cdr first-i 144 | n-list))))) (car first-in-list)))) (car (cdr pair) 145 | )))) (car pair)))) (cdr list)))) (car list)))))))) 146 | (' (lambda (p n) (if (= n (length p)) ((' (lambda 147 | (v) (if (= success (car v)) (cons (cons (car (cdr 148 | v)) (cons 1 nil)) nil) nil))) (try n C p)) (merge 149 | (how-many? (cons 0 p) n) (how-many? (cons 1 p) n) 150 | ))))))) (' (lambda (n) ((' (lambda (previous-requi 151 | rements) (stage (+ n 1)))) (make-requirements (deb 152 | ug (how-many? nil (debug n)))))))))) (' ((' (lambd 153 | a (loop) (loop 10))) (' (lambda (n) ((' (lambda (i 154 | gnore-it) (if (= 1 (read-bit)) n (loop (* 10 n)))) 155 | ) (read-bit))))))))) nil) 156 | 157 | try 60 all-together nil 158 | 159 | expression (try 60 all-together nil) 160 | debug 0 161 | debug () 162 | debug 1 163 | debug () 164 | debug 2 165 | debug () 166 | debug 3 167 | debug ((10 4)) 168 | debug (10 2) 169 | debug 4 170 | debug ((10 8)) 171 | debug 5 172 | debug ((10 16) (100 8)) 173 | debug (100 3) 174 | debug 6 175 | debug ((10 32) (100 16)) 176 | debug 7 177 | debug ((10 64) (100 32) (1000 16)) 178 | debug (1000 4) 179 | debug 8 180 | debug ((10 128) (100 64) (1000 32)) 181 | value (failure out-of-time ((10 2) (100 3) (1000 4))) 182 | -------------------------------------------------------------------------------- /book-examples/decomp.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | FUNDAMENTAL DECOMPOSITION 3 | We prove here that 4 | H(y|x) <= H_C(x,y) - H(x) + c 5 | ]]]]] 6 | 7 | define (all-together x*) 8 | 9 | let c debug 100 [constant to satisfy Kraft (see lemma)] 10 | 11 | let x debug run-utm-on debug x* 12 | 13 | let H-of-x debug length x* 14 | 15 | [programs we've discovered that calculate pairs 16 | starting with x] 17 | let programs nil 18 | 19 | let (stage n) 20 | [generate requirements for all new programs we've 21 | discovered that produce (x y) pairs] 22 | let programs 23 | (add-to-set debug (halts? nil debug n) programs) 24 | (stage + n 1) 25 | 26 | [at stage n = 0, 1, 2, 3, ...] 27 | [look at all programs with <=n bits that halt within time n] 28 | [returns list of all of them that produce pairs (x y)] 29 | let (halts? p bits-left) 30 | let v try n C p [C is eval read-exp if C = U] 31 | if = success car v (look-at cadr v) 32 | if = 0 bits-left nil 33 | append (halts? append p cons 0 nil - bits-left 1) 34 | (halts? append p cons 1 nil - bits-left 1) 35 | 36 | [returns (p) if C(p) = (x y), otherwise ()] 37 | let (look-at v) 38 | if (and (is-pair v) 39 | = x car v ) cons p nil 40 | nil 41 | 42 | [logical "and"] 43 | let (and p q) 44 | if p q false 45 | 46 | [is x a pair?] 47 | let (is-pair? x) 48 | if atom x false 49 | if atom cdr x false 50 | if atom cdr cdr x true 51 | false 52 | 53 | [is an element in a set?] 54 | let (is-in-set? element set) 55 | if atom set false 56 | if = element car set true 57 | (is-in-set? element cdr set) 58 | 59 | [forms set union avoiding duplicates, 60 | and makes requirement for each new find] 61 | let (add-to-set new old) 62 | if atom new old 63 | let first-new car new 64 | let rest-new cdr new 65 | if (is-in-set? first-new old) (add-to-set rest-new old) 66 | (do (make-requirement first-new) 67 | cons first-new (add-to-set rest-new old) 68 | ) 69 | 70 | [first argument discarded, done for side-effect only!] 71 | let (do x y) y 72 | 73 | [given new p such that C(p) = (x y), 74 | we produce the requirement for C_x 75 | that there be a program for y that is |p|-H(x)+c bits long] 76 | let (make-requirement p) 77 | display cons cadr cadr try no-time-limit C p 78 | cons - + c length p H-of-x 79 | nil 80 | 81 | let C ' [here eval read-exp gives U] 82 | [test case special-purpose computer C here in place of U:] 83 | [C(00100001) with x-1 and y-1 0's gives pair (x xy)] 84 | [loop function gives number of bits up to next 1 bit] 85 | let (loop n) 86 | if = 1 read-bit n 87 | (loop + n 1) 88 | let x (loop 1) 89 | let y (loop 1) 90 | cons x cons * x y nil 91 | 92 | [HERE GOES!] 93 | (stage 0) 94 | 95 | define all-together 96 | value (lambda (x*) ((' (lambda (c) ((' (lambda (x) ((' ( 97 | lambda (H-of-x) ((' (lambda (programs) ((' (lambda 98 | (stage) ((' (lambda (halts?) ((' (lambda (look-at 99 | ) ((' (lambda (and) ((' (lambda (is-pair?) ((' (la 100 | mbda (is-in-set?) ((' (lambda (add-to-set) ((' (la 101 | mbda (do) ((' (lambda (make-requirement) ((' (lamb 102 | da (C) (stage 0))) (' ((' (lambda (loop) ((' (lamb 103 | da (x) ((' (lambda (y) (cons x (cons (* x y) nil)) 104 | )) (loop 1)))) (loop 1)))) (' (lambda (n) (if (= 1 105 | (read-bit)) n (loop (+ n 1)))))))))) (' (lambda ( 106 | p) (display (cons (car (cdr (car (cdr (try no-time 107 | -limit C p))))) (cons (- (+ c (length p)) H-of-x) 108 | nil)))))))) (' (lambda (x y) y))))) (' (lambda (ne 109 | w old) (if (atom new) old ((' (lambda (first-new) 110 | ((' (lambda (rest-new) (if (is-in-set? first-new o 111 | ld) (add-to-set rest-new old) (do (make-requiremen 112 | t first-new) (cons first-new (add-to-set rest-new 113 | old)))))) (cdr new)))) (car new)))))))) (' (lambda 114 | (element set) (if (atom set) false (if (= element 115 | (car set)) true (is-in-set? element (cdr set))))) 116 | )))) (' (lambda (x) (if (atom x) false (if (atom ( 117 | cdr x)) false (if (atom (cdr (cdr x))) true false) 118 | ))))))) (' (lambda (p q) (if p q false)))))) (' (l 119 | ambda (v) (if (and (is-pair v) (= x (car v))) (con 120 | s p nil) nil)))))) (' (lambda (p bits-left) ((' (l 121 | ambda (v) (if (= success (car v)) (look-at (car (c 122 | dr v))) (if (= 0 bits-left) nil (append (halts? (a 123 | ppend p (cons 0 nil)) (- bits-left 1)) (halts? (ap 124 | pend p (cons 1 nil)) (- bits-left 1))))))) (try n 125 | C p))))))) (' (lambda (n) ((' (lambda (programs) ( 126 | stage (+ n 1)))) (add-to-set (debug (halts? nil (d 127 | ebug n))) programs))))))) nil))) (debug (length x* 128 | ))))) (debug (car (cdr (try no-time-limit (' (eval 129 | (read-exp))) (debug x*)))))))) (debug 100))) 130 | 131 | define x* 3 132 | 133 | define x* 134 | value 3 135 | 136 | length bits x* 137 | 138 | expression (length (bits x*)) 139 | value 16 140 | 141 | [give all-together x*] 142 | try 60 cons cons "' 143 | cons all-together 144 | nil 145 | cons cons "' 146 | cons bits x* 147 | nil 148 | nil 149 | nil 150 | 151 | expression (try 60 (cons (cons ' (cons all-together nil)) (co 152 | ns (cons ' (cons (bits x*) nil)) nil)) nil) 153 | debug 100 154 | debug (0 0 1 1 0 0 1 1 0 0 0 0 1 0 1 0) 155 | debug 3 156 | debug 16 157 | debug 0 158 | debug () 159 | debug 1 160 | debug () 161 | debug 2 162 | debug () 163 | debug 3 164 | debug () 165 | debug 4 166 | debug ((0 0 1 1)) 167 | debug 5 168 | debug ((0 0 1 0 1) (0 0 1 1)) 169 | debug 6 170 | debug ((0 0 1 0 0 1) (0 0 1 0 1) (0 0 1 1)) 171 | debug 7 172 | debug ((0 0 1 0 0 0 1) (0 0 1 0 0 1) (0 0 1 0 1) (0 0 1 173 | 1)) 174 | debug 8 175 | debug ((0 0 1 0 0 0 0 1) (0 0 1 0 0 0 1) (0 0 1 0 0 1) ( 176 | 0 0 1 0 1) (0 0 1 1)) 177 | debug 9 178 | value (failure out-of-time ((3 88) (6 89) (9 90) (12 91) 179 | (15 92))) 180 | 181 | define x* 4 182 | 183 | define x* 184 | value 4 185 | 186 | length bits x* 187 | 188 | expression (length (bits x*)) 189 | value 16 190 | 191 | [give all-together x*] 192 | try 60 cons cons "' 193 | cons all-together 194 | nil 195 | cons cons "' 196 | cons bits x* 197 | nil 198 | nil 199 | nil 200 | 201 | expression (try 60 (cons (cons ' (cons all-together nil)) (co 202 | ns (cons ' (cons (bits x*) nil)) nil)) nil) 203 | debug 100 204 | debug (0 0 1 1 0 1 0 0 0 0 0 0 1 0 1 0) 205 | debug 4 206 | debug 16 207 | debug 0 208 | debug () 209 | debug 1 210 | debug () 211 | debug 2 212 | debug () 213 | debug 3 214 | debug () 215 | debug 4 216 | debug () 217 | debug 5 218 | debug ((0 0 0 1 1)) 219 | debug 6 220 | debug ((0 0 0 1 0 1) (0 0 0 1 1)) 221 | debug 7 222 | debug ((0 0 0 1 0 0 1) (0 0 0 1 0 1) (0 0 0 1 1)) 223 | debug 8 224 | debug ((0 0 0 1 0 0 0 1) (0 0 0 1 0 0 1) (0 0 0 1 0 1) ( 225 | 0 0 0 1 1)) 226 | debug 9 227 | value (failure out-of-time ((4 89) (8 90) (12 91) (16 92 228 | ))) 229 | -------------------------------------------------------------------------------- /book-examples/utm2.r: -------------------------------------------------------------------------------- 1 | [[[ 2 | RELATIVE COMPLEXITY! 3 | Additional steps in my new construction for 4 | a self-delimiting universal Turing machine. 5 | 6 | We show that 7 | 8 | H(beta) <= n + H(n) + c for n-bit beta 9 | 10 | H(x,y) <= H(x) + H(y) + c 11 | 12 | H(H(x)|x) <= c 13 | 14 | H(x,y) <= H(x) + H(y|x) + c 15 | ]]] 16 | 17 | [ 18 | Here is the self-delimiting universal Turing machine 19 | with NO free data. P is the program. 20 | [Run-utm-on p expands to this.] 21 | ] 22 | define (U p) 23 | cadr try no-time-limit 'eval read-exp p 24 | 25 | define U 26 | value (lambda (p) (car (cdr (try no-time-limit (' (eval 27 | (read-exp))) p)))) 28 | 29 | [Here is the version of U with one piece of free data:] 30 | 31 | define (U2 p q) [q is a program for U for the free data] 32 | cadr try no-time-limit 33 | display cons 'read-exp [run ((read-exp) (' q))] 34 | cons cons "' 35 | cons q 36 | nil 37 | nil 38 | p 39 | 40 | define U2 41 | value (lambda (p q) (car (cdr (try no-time-limit (displa 42 | y (cons (' (read-exp)) (cons (cons ' (cons q nil)) 43 | nil))) p)))) 44 | 45 | [Here's the version given two things, not one:] 46 | 47 | define (U3 p q r) [q, r are programs for U for the free data] 48 | cadr try no-time-limit 49 | display cons 'read-exp [run ((read-exp) (' q) (' r))] 50 | cons cons "' 51 | cons q 52 | nil 53 | cons cons "' 54 | cons r 55 | nil 56 | nil 57 | p 58 | 59 | define U3 60 | value (lambda (p q r) (car (cdr (try no-time-limit (disp 61 | lay (cons (' (read-exp)) (cons (cons ' (cons q nil 62 | )) (cons (cons ' (cons r nil)) nil)))) p)))) 63 | 64 | [ 65 | Consider an n-bit string beta. 66 | We show that H(beta) <= n + H(n) + 912. 67 | ] 68 | define pi 69 | let (loop k) 70 | if = k 0 nil 71 | cons read-bit (loop - k 1) 72 | (loop eval read-exp) 73 | 74 | define pi 75 | value ((' (lambda (loop) (loop (eval (read-exp))))) (' ( 76 | lambda (k) (if (= k 0) nil (cons (read-bit) (loop 77 | (- k 1))))))) 78 | 79 | [Size it.] 80 | length bits pi 81 | 82 | expression (length (bits pi)) 83 | value 912 84 | 85 | [Use it.] 86 | (U 87 | append bits pi 88 | append bits 12 89 | '(0 0 1 1 1 1 1 1 0 0 0 1) 90 | ) 91 | 92 | expression (U (append (bits pi) (append (bits 12) (' (0 0 1 1 93 | 1 1 1 1 0 0 0 1))))) 94 | value (0 0 1 1 1 1 1 1 0 0 0 1) 95 | 96 | [ 97 | Proof that H(x,y) <= H(x) + H(y) + 432. 98 | ] 99 | define rho 100 | cons eval read-exp cons eval read-exp nil 101 | 102 | define rho 103 | value (cons (eval (read-exp)) (cons (eval (read-exp)) ni 104 | l)) 105 | 106 | [Size it.] 107 | length bits rho 108 | 109 | expression (length (bits rho)) 110 | value 432 111 | 112 | [Use it.] 113 | (U 114 | append bits rho 115 | append bits pi 116 | append bits 5 117 | append '(1 1 1 1 1) 118 | append bits pi 119 | append bits 9 120 | '(0 0 0 0 0 0 0 0 0) 121 | ) 122 | 123 | expression (U (append (bits rho) (append (bits pi) (append (b 124 | its 5) (append (' (1 1 1 1 1)) (append (bits pi) ( 125 | append (bits 9) (' (0 0 0 0 0 0 0 0 0))))))))) 126 | value ((1 1 1 1 1) (0 0 0 0 0 0 0 0 0)) 127 | 128 | [ 129 | Proof that H(H(x)|x) <= 208. 130 | ] 131 | define (alpha x*) [x* = minimum-size program for x] 132 | length x* 133 | 134 | define alpha 135 | value (lambda (x*) (length x*)) 136 | 137 | [get H(x) from x*] 138 | [Size it.] 139 | length bits alpha 140 | 141 | expression (length (bits alpha)) 142 | value 208 143 | 144 | [Use it.] 145 | 146 | (U2 147 | 148 | [This is the program to calculate H(x):] 149 | 150 | bits alpha 151 | 152 | [This is the program x* for x,] 153 | [supposedly smallest possible:] 154 | 155 | bits' + 1 1 156 | 157 | ) 158 | 159 | expression (U2 (bits alpha) (bits (' (+ 1 1)))) 160 | display ((read-exp) (' (0 0 1 0 1 0 0 0 0 0 1 0 1 0 1 1 0 161 | 0 1 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 1 0 0 0 0 0 0 0 162 | 1 1 0 0 0 1 0 0 1 0 1 0 0 1 0 0 0 0 1 0 1 0))) 163 | value 64 164 | 165 | [Check size of program is correct] 166 | * 8 + 1 display size display '+ 1 1 167 | 168 | expression (* 8 (+ 1 (display (size (display (' (+ 1 1))))))) 169 | display (+ 1 1) 170 | display 7 171 | value 64 172 | 173 | [ 174 | Proof that H(x,y) <= H(x) + H(y|x) + 2872. 175 | 176 | The 2872-bit prefix gamma proves this. 177 | 178 | Gamma does the job, but it's slow. 179 | So below we will present delta, which is a greatly 180 | sped up version of gamma. The speed up is 181 | achieved by introducing a new primitive function 182 | to do the job. The was-read mechanism used below 183 | is much faster than our technique here using try 184 | to get the bits of the program p = x* as we run it. 185 | ] 186 | 187 | define gamma 188 | 189 | [read program p bit by bit until we get it all] 190 | 191 | let (loop p) 192 | if = success car try no-time-limit 'eval read-exp p 193 | [then] p 194 | [else] (loop append p cons read-bit nil) 195 | 196 | let x* (loop nil) [get x* = program for x] 197 | let x run-utm-on x* [get x from x*] 198 | let y [get y from x* by running] 199 | eval cons 'read-exp [((read-exp) (' x*))] 200 | cons cons "' 201 | cons x* 202 | nil 203 | nil 204 | 205 | [form the pair x, y] 206 | cons x cons y nil 207 | 208 | define gamma 209 | value ((' (lambda (loop) ((' (lambda (x*) ((' (lambda (x 210 | ) ((' (lambda (y) (cons x (cons y nil)))) (eval (c 211 | ons (' (read-exp)) (cons (cons ' (cons x* nil)) ni 212 | l)))))) (car (cdr (try no-time-limit (' (eval (rea 213 | d-exp))) x*)))))) (loop nil)))) (' (lambda (p) (if 214 | (= success (car (try no-time-limit (' (eval (read 215 | -exp))) p))) p (loop (append p (cons (read-bit) ni 216 | l))))))) 217 | 218 | [Size it.] 219 | length bits gamma 220 | 221 | expression (length (bits gamma)) 222 | value 2872 223 | 224 | [Use it.] 225 | 226 | run-utm-on 227 | 228 | [get pair x, y by combining ] 229 | [a program for x and a program to get y from x] 230 | 231 | append 232 | 233 | bits gamma 234 | 235 | append 236 | 237 | [x* = program to calculate x = 2] 238 | [[Supposedly x* is smallest possible,]] 239 | [[but this works for ANY x* for x.]] 240 | 241 | bits' + 1 1 242 | 243 | [program to calculate y = x+1 from x*] 244 | 245 | bits' lambda(x*) + 1 run-utm-on x* 246 | 247 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 248 | (append (bits gamma) (append (bits (' (+ 1 1))) ( 249 | bits (' (lambda (x*) (+ 1 (car (cdr (try no-time-l 250 | imit (' (eval (read-exp))) x*)))))))))))) 251 | value (2 3) 252 | 253 | [ 254 | This technique for getting a program as well as its output 255 | by inching along using try is slow. 256 | 257 | Now let's speed up gamma by adding a new primitive function. 258 | Was-read gives the binary data read so far in the current try. 259 | With it we will prove that H(x,y) <= H(x) + H(y|x) + 2104. 260 | ] 261 | define delta [knows that its own size is 2104 bits] 262 | let (skip n s) [skip first n bits of bit string s] 263 | if = n 0 s (skip - n 1 cdr s) [used to erase delta from was-read] 264 | let x eval read-exp [get x] 265 | let x* (skip 2104 was-read) [get program for x] 266 | let y [calculate y from the program for x by] 267 | eval cons 'read-exp [running ((read-exp) (' x*))] 268 | cons cons "' 269 | cons x* 270 | nil 271 | nil 272 | [form the pair x, y] 273 | cons x cons y nil 274 | 275 | define delta 276 | value ((' (lambda (skip) ((' (lambda (x) ((' (lambda (x* 277 | ) ((' (lambda (y) (cons x (cons y nil)))) (eval (c 278 | ons (' (read-exp)) (cons (cons ' (cons x* nil)) ni 279 | l)))))) (skip 2104 (was-read))))) (eval (read-exp) 280 | )))) (' (lambda (n s) (if (= n 0) s (skip (- n 1) 281 | (cdr s)))))) 282 | 283 | 284 | [Size it.] 285 | length bits delta 286 | 287 | expression (length (bits delta)) 288 | value 2104 289 | 290 | [Use it.] 291 | 292 | run-utm-on 293 | 294 | [get pair x, y by combining ] 295 | [a program for x and a program to get y from x] 296 | 297 | append 298 | 299 | bits delta 300 | 301 | append 302 | 303 | [x* = program to calculate x = 2] 304 | [[Supposedly x* is smallest possible,]] 305 | [[but this works for ANY x* for x.]] 306 | 307 | bits' + 1 1 308 | 309 | [program to calculate y = x+1 from x*] 310 | 311 | bits' lambda(x*) + 1 run-utm-on x* 312 | 313 | expression (car (cdr (try no-time-limit (' (eval (read-exp))) 314 | (append (bits delta) (append (bits (' (+ 1 1))) ( 315 | bits (' (lambda (x*) (+ 1 (car (cdr (try no-time-l 316 | imit (' (eval (read-exp))) x*)))))))))))) 317 | value (2 3) 318 | -------------------------------------------------------------------------------- /book-examples/solovay.l: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Solovay random 3 | iff it is Martin-Lof random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [First part: not M-L random ===> not Solovay random] 16 | 17 | [ 18 | This is immediate. We are given coverings A_k such 19 | that real r is in A_k for all k and the measure of A_k <= 2^{-k}. 20 | It follows immediately that r is in infinitely many of the 21 | A_k and the sum of the measure of A_k summed over all k converges. 22 | Thus r is not Solovay random. 23 | ] 24 | 25 | [Second part: not Solovay random ===> not M-L random] 26 | 27 | [ 28 | Suppose that a real r is in infinitely many of the 29 | coverings A_n and that Sum_k mu A_n <= 2^c. 30 | Consider B_k defined as the set of all reals that are 31 | in at least 2^{k+c} of the A_n. 32 | Then r is in all of the B_k and the measure of 33 | B_k is <= 2^{-k}, so r is not Martin-Lof random. 34 | 35 | Now let's program this! 36 | 37 | Instead, I'll program B_k which is the set of all reals 38 | that are in at least k of the A_n. 39 | The proof then results from considering B_{2^{k+c}} . 40 | 41 | The main function has two parameters, the stage n, and 42 | the number of times something has to be repeated to 43 | be taken into account. At stage n, with number 44 | of repeats r, we look at A_0 through A_n for time n, 45 | and put into our condensed result cover only subintervals 46 | that are covered at least r times. 47 | 48 | The key auxiliary function given n generates A_0 through A_n for time n, 49 | then expands all intervals to the same max length and counts how 50 | many times each is repeated. Then it is easy to select those that 51 | are covered the requisite number of times. 52 | 53 | First step is to run A_0 through A_n for time n and append the results. 54 | Then we get the max length and do a binary tree walk. We start with 55 | s and see if it's a prefix of at least r things. 56 | If so, s will be in our result, and we backtrack. 57 | If not, if s has max length, we stop recursion. 58 | Otherwise, we look at s0 and at s1. 59 | And we start with s = nil. 60 | This gives our covering at stage n, 61 | then we have to eliminate overlaps to 62 | get our final result. 63 | ] 64 | 65 | [ 66 | Test case: A_n is defined to be the set of 67 | all natural numbers greater than n, 68 | where k is represented as k 1's followed by a 0. 69 | Then measure of A_n is 2^{-n-1}, and 70 | 1=10 is in one of the A_n, 2=110 is in two of them, 71 | 3=1110 is in three of them, etc. 72 | 73 | I.e., 1=10 is only in A_0, 74 | 2=110 is only in A_0 & A_1, 75 | 3=1110 is only in A_0 A_1 & A_2, etc. 76 | 77 | In this case the total measure of the A_n is 78 | 1/2 + 1/4 + 1/8 + ... = 1. 79 | For the proof in general, all we know is that 80 | this total measure converges to a finite sum, not 1. 81 | ] 82 | define (A n) [displays infinite set 1^k 0, k > n] 83 | let (loop k) 84 | cons display 85 | append base10-to-2 - ^ 2 k 1 [2^k - 1 = k 1's] 86 | cons 0 nil [followed by a 0 bit] 87 | (loop + k 1) 88 | (loop + n 1) 89 | 90 | [now put together in one list stage n of A_0 through A_n] 91 | define (sum n) 92 | let (loop k sum) 93 | if > k n sum 94 | (loop + k 1 95 | append caddr try n cons cons "' cons A nil cons k nil nil 96 | sum) 97 | (loop 0 nil) 98 | 99 | [ 100 | (count x y) 101 | Now count how many times something x is contained in / 102 | is an extension of an element of y 103 | ] 104 | define (count x y) 105 | if atom y 0 106 | if (is-prefix-of? car y x) + 1 (count x cdr y) 107 | (count x cdr y) 108 | 109 | define (is-prefix-of? x y) [is bit string x a prefix of bit string y?] 110 | if atom x true 111 | if atom y false 112 | if = car x car y (is-prefix-of? cdr x cdr y) 113 | false 114 | 115 | [get maximum length of a list of bit strings] 116 | define (max-length list) 117 | if atom list 0 118 | let len1 length car list 119 | let len2 (max-length cdr list) 120 | if > len1 len2 121 | [then] len1 122 | [else] len2 123 | 124 | [ 125 | Now we get what (sum n) covers with multiplicity >= k. 126 | The measure of the multiplicity k covering will 127 | be bounded by the finite total measure (here 1) divided by k. 128 | ] 129 | 130 | define (exceeds-count n k) 131 | let sum-n (sum n) 132 | let max-length-sum-n (max-length sum-n) 133 | (look-at nil) 134 | 135 | [ 136 | This routine has free parameters sum-n, max-length-sum-n, k. 137 | It gets us the MINIMAL multiplicity >= k covering for (sum n)! 138 | ] 139 | define (look-at x) [produces strings x covered with multiplicity >= k in (sum n)] 140 | if = length x max-length-sum-n 141 | let n (count x sum-n) 142 | if >= n k cons x nil [found an interval x that is covered >= k times] 143 | nil [didn't find an interval x that is covered >= k times] 144 | [otherwise break x into subintervals] 145 | let x0 append x cons 0 nil 146 | let x1 append x cons 1 nil 147 | let v append (look-at x0) 148 | (look-at x1) 149 | [consolidate subintervals?] 150 | if = v cons x0 cons x1 nil [yes!] cons x nil 151 | [no, leave covering as is] v 152 | 153 | [ 154 | Now we put this all together into B_k, which is 155 | the limit as n goes to infinity of (exceeds-count n k), 156 | k fixed, n --> infinity. 157 | 158 | I.e., B_k is what A_0, A_1, A_2, ... covers with 159 | multiplicity >= k. 160 | 161 | Thus the measure of B_k will be bounded by the 162 | total measure of the A_n (if it exists) divided by k. 163 | 164 | The main problem is to avoid overlaps in B_k, 165 | which we do using a completely general algorithm. 166 | ] 167 | 168 | [list of intervals in covering so far] 169 | [used to avoid overlapping intervals in covering] 170 | define intervals () 171 | 172 | define (process-all x) [process list of intervals x] 173 | if atom x intervals 174 | let intervals append (process car x) intervals 175 | (process-all cdr x) 176 | 177 | define (process interval) [process individual interval] 178 | if (new-interval-covered-by-previous-one? interval intervals) 179 | [then don't need to repeat it] 180 | nil 181 | let holes (new-interval-covers-previous-ones interval intervals) 182 | if atom holes 183 | [then interval is fine as is] 184 | [output it with display!] 185 | cons display interval nil 186 | [get max granularity needed] 187 | let max (max-length holes) 188 | [convert everything to same granularity] 189 | let holes (extend-all holes max) 190 | [and remove overlap] 191 | [subtract will output residue with display] 192 | (subtract (extend interval max) holes) 193 | 194 | [returns true/false] 195 | define (new-interval-covered-by-previous-one? interval intervals) 196 | if atom intervals false 197 | if (is-prefix-of? car intervals interval) true 198 | (new-interval-covered-by-previous-one? interval cdr intervals) 199 | 200 | [returns set of previous intervals covered by this one] 201 | define (new-interval-covers-previous-ones interval intervals) 202 | if atom intervals nil 203 | if (is-prefix-of? interval car intervals) 204 | [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals) 205 | [else] (new-interval-covers-previous-ones interval cdr intervals) 206 | 207 | [produce set of all extensions of a given bit string to a given length] 208 | [(assumed >= to its current length)] 209 | define (extend bit-string len) 210 | if = len length bit-string 211 | [has correct length; return singleton set] 212 | cons bit-string nil 213 | append (extend append bit-string cons 0 nil len) 214 | (extend append bit-string cons 1 nil len) 215 | 216 | [extend all the bit strings in a given list to the same length] 217 | define (extend-all list len) 218 | if atom list nil 219 | append (extend car list len) 220 | (extend-all cdr list len) 221 | 222 | [subtract set of intervals y from set of intervals x] 223 | [output residue with display!] 224 | define (subtract x y) 225 | if atom x nil 226 | if (is-in? car x y) 227 | [then] (subtract cdr x y) 228 | [else] cons display car x (subtract cdr x y) 229 | 230 | define (is-in? x l) [is x an element of list l?] 231 | if atom l false 232 | if = x car l true 233 | (is-in? x cdr l) 234 | 235 | [ 236 | Put it all together---Here is cover B_k, 237 | which is what is covered by A_0, A_1, A_2, ... 238 | with multiplicity >= k, and therefore has 239 | measure bounded by the total measure of the A_n 240 | divided by k. 241 | Supposing that this total measure is <= 2^c 242 | and considering B_{2^{k+c}}, 243 | we see that if a real r is in infinitely many of 244 | the A_n, then it will be in all of the 245 | B_{2^{k+c}}, each of which has measure <= 1/2^k. 246 | Hence if a real r is not Solovay random, 247 | it follows that it will not be M-L random. 248 | Here we write the code for B_k, not for 249 | B_{2^{k+c}}. 250 | ] 251 | define (B k) 252 | let intervals nil 253 | let (stage n) 254 | if = n 6 stop! [to stop test run---remove if real thing] 255 | let exceed-count (exceeds-count n k) 256 | let intervals (process-all exceed-count) 257 | (stage + 1 n) 258 | [go!!!!!] 259 | (stage 0) 260 | 261 | [k = multiplicity = repeated/covered 2 or more times in the A_n] 262 | (B 2) 263 | -------------------------------------------------------------------------------- /book-examples/martin-lof2.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Martin-Lof random 3 | iff it is Chaitin random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [Second part: not Ch random ===> not M-L random] 16 | 17 | define (is-in? x l) [is x an element of list l?] 18 | if atom l false 19 | if = x car l true 20 | (is-in? x cdr l) 21 | 22 | define is-in? 23 | value (lambda (x l) (if (atom l) false (if (= x (car l)) 24 | true (is-in? x (cdr l))))) 25 | 26 | define (is-prefix-of? x y) [is bit string x a prefix of bit string y?] 27 | if atom x true 28 | if atom y false 29 | if = car x car y (is-prefix-of? cdr x cdr y) 30 | false 31 | 32 | define is-prefix-of? 33 | value (lambda (x y) (if (atom x) true (if (atom y) false 34 | (if (= (car x) (car y)) (is-prefix-of? (cdr x) (c 35 | dr y)) false)))) 36 | 37 | define (is-bit-string? x) [is x a list of 0's and 1's?] 38 | if = x nil true 39 | if atom x false 40 | if = 0 car x (is-bit-string? cdr x) 41 | if = 1 car x (is-bit-string? cdr x) 42 | false 43 | 44 | define is-bit-string? 45 | value (lambda (x) (if (= x nil) true (if (atom x) false 46 | (if (= 0 (car x)) (is-bit-string? (cdr x)) (if (= 47 | 1 (car x)) (is-bit-string? (cdr x)) false))))) 48 | 49 | define C [test computer---real thing is eval read-exp] 50 | let (loop) [doubles all bits up to & including first 1] 51 | if = 1 read-bit '(1 1) 52 | cons 0 cons 0 (loop) 53 | (loop) 54 | 55 | define C 56 | value ((' (lambda (loop) (loop))) (' (lambda () (if (= 1 57 | (read-bit)) (' (1 1)) (cons 0 (cons 0 (loop)))))) 58 | ) 59 | 60 | [Now let's do stage n of A_k = strings s with H(s) <= |s| - k.] 61 | [At stage n we look at programs p up to n bits in size for time up to n.] 62 | 63 | define (compressible-by-k n k) 64 | (look-at nil) 65 | 66 | define compressible-by-k 67 | value (lambda (n k) (look-at nil)) 68 | 69 | [this routine has free parameters n, k, C] 70 | 71 | define (look-at p) [produces strings compressible by k within time n] 72 | let v try n C ['eval read-exp] p 73 | if = success car v 74 | let w cadr v 75 | if (is-bit-string? w) 76 | if >= length w + k length p 77 | cons w nil 78 | nil 79 | nil 80 | [otherwise failure] 81 | if = n length p nil [stop!] 82 | append (look-at append p cons 0 nil) 83 | (look-at append p cons 1 nil) 84 | 85 | define look-at 86 | value (lambda (p) ((' (lambda (v) (if (= success (car v) 87 | ) ((' (lambda (w) (if (is-bit-string? w) (if (>= ( 88 | length w) (+ k (length p))) (cons w nil) nil) nil) 89 | )) (car (cdr v))) (if (= n (length p)) nil (append 90 | (look-at (append p (cons 0 nil))) (look-at (appen 91 | d p (cons 1 nil)))))))) (try n C p))) 92 | 93 | [list of intervals in covering so far] 94 | [used to avoid overlapping intervals in covering] 95 | define intervals () 96 | 97 | define intervals 98 | value () 99 | 100 | define (process-all x) [process list of intervals x] 101 | if atom x intervals 102 | let intervals append (process car x) intervals 103 | (process-all cdr x) 104 | 105 | define process-all 106 | value (lambda (x) (if (atom x) intervals ((' (lambda (in 107 | tervals) (process-all (cdr x)))) (append (process 108 | (car x)) intervals)))) 109 | 110 | define (process interval) [process individual interval] 111 | if (new-interval-covered-by-previous-one? interval intervals) 112 | [then don't need to repeat it] 113 | nil 114 | let holes (new-interval-covers-previous-ones interval intervals) 115 | if atom holes 116 | [then interval is fine as is] 117 | cons display interval nil 118 | [get max granularity needed] 119 | let max (max-length holes) 120 | [convert everything to same granularity] 121 | let holes (extend-all holes max) 122 | [and remove overlap] 123 | (subtract (extend interval max) holes) 124 | 125 | define process 126 | value (lambda (interval) (if (new-interval-covered-by-pr 127 | evious-one? interval intervals) nil ((' (lambda (h 128 | oles) (if (atom holes) (cons (display interval) ni 129 | l) ((' (lambda (max) ((' (lambda (holes) (subtract 130 | (extend interval max) holes))) (extend-all holes 131 | max)))) (max-length holes))))) (new-interval-cover 132 | s-previous-ones interval intervals)))) 133 | 134 | [returns true/false] 135 | define (new-interval-covered-by-previous-one? interval intervals) 136 | if atom intervals false 137 | if (is-prefix-of? car intervals interval) true 138 | (new-interval-covered-by-previous-one? interval cdr intervals) 139 | 140 | define new-interval-covered-by-previous-one? 141 | value (lambda (interval intervals) (if (atom intervals) 142 | false (if (is-prefix-of? (car intervals) interval) 143 | true (new-interval-covered-by-previous-one? inter 144 | val (cdr intervals))))) 145 | 146 | [returns set of previous intervals covered by this one] 147 | define (new-interval-covers-previous-ones interval intervals) 148 | if atom intervals nil 149 | if (is-prefix-of? interval car intervals) 150 | [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals) 151 | [else] (new-interval-covers-previous-ones interval cdr intervals) 152 | 153 | define new-interval-covers-previous-ones 154 | value (lambda (interval intervals) (if (atom intervals) 155 | nil (if (is-prefix-of? interval (car intervals)) ( 156 | cons (car intervals) (new-interval-covers-previous 157 | -ones interval (cdr intervals))) (new-interval-cov 158 | ers-previous-ones interval (cdr intervals))))) 159 | 160 | 161 | [get maximum length of a list of bit strings] 162 | define (max-length list) 163 | if atom list 0 164 | let len1 length car list 165 | let len2 (max-length cdr list) 166 | if > len1 len2 167 | [then] len1 168 | [else] len2 169 | 170 | define max-length 171 | value (lambda (list) (if (atom list) 0 ((' (lambda (len1 172 | ) ((' (lambda (len2) (if (> len1 len2) len1 len2)) 173 | ) (max-length (cdr list))))) (length (car list)))) 174 | ) 175 | 176 | [produce set of all extensions of a given bit string to a given length] 177 | [(assumed >= to its current length)] 178 | define (extend bit-string len) 179 | if = len length bit-string 180 | [has correct length; return singleton set] 181 | cons bit-string nil 182 | append (extend append bit-string cons 0 nil len) 183 | (extend append bit-string cons 1 nil len) 184 | 185 | define extend 186 | value (lambda (bit-string len) (if (= len (length bit-st 187 | ring)) (cons bit-string nil) (append (extend (appe 188 | nd bit-string (cons 0 nil)) len) (extend (append b 189 | it-string (cons 1 nil)) len)))) 190 | 191 | [extend all the bit strings in a given list to the same length] 192 | define (extend-all list len) 193 | if atom list nil 194 | append (extend car list len) 195 | (extend-all cdr list len) 196 | 197 | define extend-all 198 | value (lambda (list len) (if (atom list) nil (append (ex 199 | tend (car list) len) (extend-all (cdr list) len))) 200 | ) 201 | 202 | [subtract set of intervals y from set of intervals x] 203 | define (subtract x y) 204 | if atom x nil 205 | if (is-in? car x y) 206 | [then] (subtract cdr x y) 207 | [else] cons debug display car x (subtract cdr x y) 208 | 209 | define subtract 210 | value (lambda (x y) (if (atom x) nil (if (is-in? (car x) 211 | y) (subtract (cdr x) y) (cons (debug (display (ca 212 | r x))) (subtract (cdr x) y))))) 213 | 214 | [ 215 | Put it all together---Here is cover A_k 216 | covering all reals r having any n-bit prefix r_n 217 | with H(r_n) <= n - k. 218 | And we have measure \mu A_k <= 2^{-k+c}. 219 | Actual proof uses A_{k+c} 220 | so that measure \mu A_{k+c} <= 2^{-k}. 221 | Hence a real r with prefixes whose complexity 222 | dips arbitrarily far below their length will be 223 | in all the A_k and hence will not be M-L random. 224 | ] 225 | define (A k) 226 | let intervals nil 227 | let (stage n) 228 | let compressible-strings (compressible-by-k n k) 229 | let intervals (process-all compressible-strings) 230 | if = n 12 stop! [to stop test run---remove if real thing] 231 | (stage + 1 n) 232 | [go!!!!!] 233 | (stage 0) 234 | 235 | define A 236 | value (lambda (k) ((' (lambda (intervals) ((' (lambda (s 237 | tage) (stage 0))) (' (lambda (n) ((' (lambda (comp 238 | ressible-strings) ((' (lambda (intervals) (if (= n 239 | 12) stop! (stage (+ 1 n))))) (process-all compres 240 | sible-strings)))) (compressible-by-k n k))))))) ni 241 | l)) 242 | 243 | [k = compression amount = 8 bits] 244 | (A 8) 245 | 246 | expression (A 8) 247 | display (0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 248 | display (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 249 | display (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 250 | display (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 251 | value stop! 252 | -------------------------------------------------------------------------------- /book-examples/kraft.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | KRAFT INEQUALITY CRITERION FOR CONSTRUCTING COMPUTERS 3 | Take as input requirement pairs (output, size of program) 4 | and produce as output assignment pairs (program, output). 5 | 6 | We assume that the requirements are consistent. 7 | I.e. the sum of 1/2 raised to each size is <= unity. 8 | Then we can produce a set of assignments that meets 9 | the requirements and is prefex free, i.e. no extension 10 | of a valid program is a valid program. 11 | 12 | The basic data structure in this program is the free space pool. 13 | That's a list of prefixes all of whose extensions (by zero 14 | or more bits) are unassigned programs. Initially this is the 15 | list consisting of the empty string because everything is free. 16 | 17 | The algorithm consists of assigning that program that meets 18 | each requirement that is available and that comes first in 19 | lexicographic order (0 before 1). 20 | 21 | The free space pool is kept in lexicographic order, to facilitate 22 | searching. So the algorithm is to look for the first prefix in 23 | the pool that is <= the requested size in each requirement. 24 | 25 | If it has exactly the requested size, then that prefix is the 26 | program assigned to the output in the requirement. If not, 27 | the prefix must be smaller than the requirement, and represents 28 | a piece of free storage that is a power of two larger than needed. 29 | So as program we assign the prefix extended by sufficiently many 30 | 0's to reach the requested size, and then the prefix is replaced 31 | in the free space pool by prefix00001, prefix0001, prefix001, 32 | prefix01, prefix1, for all sizes up to the assigned size. 33 | This will always work if the Kraft inequality is satisfied. 34 | 35 | If this algorithm is given the requirements 36 | (0 1) (1 2) (2 3) (3 4)... 37 | (i.e., a 1-bit p for 0, a 2-bit p for 1, a 3-bit p for 2, etc.) 38 | it will produce the assignments 39 | (0 0) (10 1) (110 2) (1110 3)... 40 | (i.e., p = 0 yields 0, p = 10 yields 1, p = 110 yields 2, etc.) 41 | In this case the free storage pool will always consist of a 42 | single piece. 43 | 44 | Key fact: if you follow this first-fit algorithm, the free space 45 | will appear in blocks in the unit interval whose sizes are all 46 | distinct powers of two, and in order of increasing size. So 47 | if an allocation cannot be made, the piece requested must be 48 | larger (at least twice as large) as the last & largest piece. 49 | But the total free storage is less than twice the size of the 50 | last & largest free piece, so allocating this would have violated 51 | the Kraft inequality. 52 | 53 | To actually run these programs, we have to feed the output of 54 | this program kraft.l into the previous one, exec.l. 55 | So there will in fact be an additional prefix in front of the 56 | assigned programs to tell U how to do kraft.l and how to do exec.l. 57 | 58 | Kraft is written as a function that is applied to a finite list 59 | of requirements and produces the corresponding finite list of 60 | assignments. Exec.l will use try to run the requirement generator 61 | for more and more time to produce longer and longer lists of 62 | assignments. It will then use the Kraft function to transform 63 | these into longer and longer lists of assignments, which it will 64 | use to actually run individual programs by reading them bit by 65 | bit as required. The Kraft function has the property that applying 66 | it to a longer list of requirements just produces a longer list 67 | of assignments. I.e., it's monotone, it never changes its mind. 68 | ]]]]] 69 | 70 | [used to assign a program to an output] 71 | 72 | define (extend-with-0s bit-string [to] given-length) 73 | if = length bit-string given-length [then] 74 | bit-string [else] 75 | append (extend-with-0s bit-string [to] - given-length 1) 76 | cons 0 nil 77 | 78 | define extend-with-0s 79 | value (lambda (bit-string given-length) (if (= (length b 80 | it-string) given-length) bit-string (append (exten 81 | d-with-0s bit-string (- given-length 1)) (cons 0 n 82 | il)))) 83 | 84 | [test it] 85 | 86 | (extend-with-0s '(1 1 1) [to] 6) 87 | 88 | expression (extend-with-0s (' (1 1 1)) 6) 89 | value (1 1 1 0 0 0) 90 | 91 | (extend-with-0s '(1 1 1) [to] 5) 92 | 93 | expression (extend-with-0s (' (1 1 1)) 5) 94 | value (1 1 1 0 0) 95 | 96 | (extend-with-0s '(1 1 1) [to] 4) 97 | 98 | expression (extend-with-0s (' (1 1 1)) 4) 99 | value (1 1 1 0) 100 | 101 | (extend-with-0s '(1 1 1) [to] 3) 102 | 103 | expression (extend-with-0s (' (1 1 1)) 3) 104 | value (1 1 1) 105 | 106 | [used to subtract storage from a piece of free storage] 107 | 108 | define (remove-piece free-prefix size-of-program) 109 | if = size-of-program length free-prefix 110 | nil [then no storage left, else] 111 | cons append (extend-with-0s free-prefix [to] - size-of-program 1) 112 | cons 1 nil 113 | (remove-piece free-prefix - size-of-program 1) 114 | 115 | define remove-piece 116 | value (lambda (free-prefix size-of-program) (if (= size- 117 | of-program (length free-prefix)) nil (cons (append 118 | (extend-with-0s free-prefix (- size-of-program 1) 119 | ) (cons 1 nil)) (remove-piece free-prefix (- size- 120 | of-program 1))))) 121 | 122 | [test it] 123 | 124 | (remove-piece '(1 1 1) 6) 125 | 126 | expression (remove-piece (' (1 1 1)) 6) 127 | value ((1 1 1 0 0 1) (1 1 1 0 1) (1 1 1 1)) 128 | 129 | (remove-piece '(1 1 1) 5) 130 | 131 | expression (remove-piece (' (1 1 1)) 5) 132 | value ((1 1 1 0 1) (1 1 1 1)) 133 | 134 | (remove-piece '(1 1 1) 4) 135 | 136 | expression (remove-piece (' (1 1 1)) 4) 137 | value ((1 1 1 1)) 138 | 139 | (remove-piece '(1 1 1) 3) 140 | 141 | expression (remove-piece (' (1 1 1)) 3) 142 | value () 143 | 144 | [ 145 | Make-assignments uses debug to show us the 146 | free-space-pool after making each assignment. 147 | If an assignment cannot be made because 148 | there is not enough storage, we just skip it. 149 | ] 150 | define (make-assignments free-space-pool requirements) 151 | 152 | let free-space-pool debug free-space-pool 153 | [Done just to show pool!] 154 | 155 | if atom requirements nil [no requirements => no assignments] 156 | [If so, we're finished!] 157 | 158 | let requirement car requirements 159 | let requirements cdr requirements 160 | let output-of-program car requirement 161 | let size-of-program cadr requirement 162 | let already-scanned nil 163 | let not-yet-scanned free-space-pool 164 | 165 | let (loop-thru-free-space-pool) [DEFINE IT!] 166 | 167 | if atom not-yet-scanned [cannot make this assignment!] 168 | [indicate problem and go to next requirement] 169 | cons not-enough-storage! 170 | (make-assignments free-space-pool requirements) 171 | 172 | let free-prefix car not-yet-scanned 173 | let not-yet-scanned cdr not-yet-scanned 174 | if < size-of-program length free-prefix 175 | 176 | [doesn't fit --- continue scanning] 177 | let already-scanned 178 | append already-scanned 179 | cons free-prefix nil 180 | (loop-thru-free-space-pool) 181 | 182 | [fits! --- make assignment] 183 | [add to list of rest of assignments] 184 | let free-space-pool 185 | append already-scanned 186 | append (remove-piece free-prefix size-of-program) 187 | not-yet-scanned 188 | 189 | let assignment 190 | [make assignment - add to list of rest of assignments] 191 | [found free piece where it fits!] 192 | [extend with zeros to correct size] 193 | cons (extend-with-0s free-prefix [to] size-of-program) 194 | cons output-of-program 195 | nil 196 | 197 | [return full list of assignments] 198 | cons assignment 199 | (make-assignments free-space-pool requirements) 200 | 201 | [NOW DO IT!] 202 | (loop-thru-free-space-pool) 203 | 204 | define make-assignments 205 | value (lambda (free-space-pool requirements) ((' (lambda 206 | (free-space-pool) (if (atom requirements) nil ((' 207 | (lambda (requirement) ((' (lambda (requirements) 208 | ((' (lambda (output-of-program) ((' (lambda (size- 209 | of-program) ((' (lambda (already-scanned) ((' (lam 210 | bda (not-yet-scanned) ((' (lambda (loop-thru-free- 211 | space-pool) (loop-thru-free-space-pool))) (' (lamb 212 | da () (if (atom not-yet-scanned) (cons not-enough- 213 | storage! (make-assignments free-space-pool require 214 | ments)) ((' (lambda (free-prefix) ((' (lambda (not 215 | -yet-scanned) (if (< size-of-program (length free- 216 | prefix)) ((' (lambda (already-scanned) (loop-thru- 217 | free-space-pool))) (append already-scanned (cons f 218 | ree-prefix nil))) ((' (lambda (free-space-pool) (( 219 | ' (lambda (assignment) (cons assignment (make-assi 220 | gnments free-space-pool requirements)))) (cons (ex 221 | tend-with-0s free-prefix size-of-program) (cons ou 222 | tput-of-program nil))))) (append already-scanned ( 223 | append (remove-piece free-prefix size-of-program) 224 | not-yet-scanned)))))) (cdr not-yet-scanned)))) (ca 225 | r not-yet-scanned)))))))) free-space-pool))) nil)) 226 | ) (car (cdr requirement))))) (car requirement)))) 227 | (cdr requirements)))) (car requirements))))) (debu 228 | g free-space-pool))) 229 | 230 | [put it all together] 231 | 232 | define (kraft requirements) 233 | 234 | let free-space-pool '(()) [everything free] 235 | 236 | (make-assignments free-space-pool requirements) 237 | 238 | define kraft 239 | value (lambda (requirements) ((' (lambda (free-space-poo 240 | l) (make-assignments free-space-pool requirements) 241 | )) (' (())))) 242 | 243 | [TEST KRAFT!] 244 | 245 | (kraft '((x 0) (y 1))) 246 | 247 | expression (kraft (' ((x 0) (y 1)))) 248 | debug (()) 249 | debug () 250 | debug () 251 | value ((() x) not-enough-storage!) 252 | 253 | 254 | (kraft '((a 1) (b 0) (c 1))) 255 | 256 | expression (kraft (' ((a 1) (b 0) (c 1)))) 257 | debug (()) 258 | debug ((1)) 259 | debug ((1)) 260 | debug () 261 | value (((0) a) not-enough-storage! ((1) c)) 262 | 263 | 264 | (kraft '((x 1) (y 2))) 265 | 266 | expression (kraft (' ((x 1) (y 2)))) 267 | debug (()) 268 | debug ((1)) 269 | debug ((1 1)) 270 | value (((0) x) ((1 0) y)) 271 | 272 | 273 | (kraft '((a 1) (b 2) (c 3) (d 4) (e 5))) 274 | 275 | expression (kraft (' ((a 1) (b 2) (c 3) (d 4) (e 5)))) 276 | debug (()) 277 | debug ((1)) 278 | debug ((1 1)) 279 | debug ((1 1 1)) 280 | debug ((1 1 1 1)) 281 | debug ((1 1 1 1 1)) 282 | value (((0) a) ((1 0) b) ((1 1 0) c) ((1 1 1 0) d) ((1 1 283 | 1 1 0) e)) 284 | 285 | 286 | (kraft '((e 5) (d 4) (c 3) (b 2) (a 1))) 287 | 288 | expression (kraft (' ((e 5) (d 4) (c 3) (b 2) (a 1)))) 289 | debug (()) 290 | debug ((0 0 0 0 1) (0 0 0 1) (0 0 1) (0 1) (1)) 291 | debug ((0 0 0 0 1) (0 0 1) (0 1) (1)) 292 | debug ((0 0 0 0 1) (0 1) (1)) 293 | debug ((0 0 0 0 1) (1)) 294 | debug ((0 0 0 0 1)) 295 | value (((0 0 0 0 0) e) ((0 0 0 1) d) ((0 0 1) c) ((0 1) 296 | b) ((1) a)) 297 | 298 | 299 | (kraft '((e 5) (c 3) (d 4) (a 1) (b 2))) 300 | 301 | expression (kraft (' ((e 5) (c 3) (d 4) (a 1) (b 2)))) 302 | debug (()) 303 | debug ((0 0 0 0 1) (0 0 0 1) (0 0 1) (0 1) (1)) 304 | debug ((0 0 0 0 1) (0 0 0 1) (0 1) (1)) 305 | debug ((0 0 0 0 1) (0 1) (1)) 306 | debug ((0 0 0 0 1) (0 1)) 307 | debug ((0 0 0 0 1)) 308 | value (((0 0 0 0 0) e) ((0 0 1) c) ((0 0 0 1) d) ((1) a) 309 | ((0 1) b)) 310 | -------------------------------------------------------------------------------- /book-examples/chaitin.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [[[[[ 4 | 5 | Show that a formal axiomatic system (fas) can only prove 6 | that finitely many LISP expressions are elegant. 7 | (An expression is elegant if no smaller expression has 8 | the same value.) 9 | 10 | More precisely, show that a fas of LISP complexity N can't 11 | prove that a LISP expression X is elegant if X's size is 12 | greater than N + 356. 13 | 14 | (fas N) returns the theorem proved by the Nth proof 15 | (Nth S-expression) in the fas, or nil if the proof is 16 | invalid, or stop to stop everything. 17 | 18 | ]]]]] 19 | 20 | [ 21 | This expression searches for an elegant expression 22 | that is larger than it is and returns the value of 23 | that expression as its own value. 24 | ] 25 | 26 | define expression [Formal Axiomatic System #1] 27 | let (fas n) if = n 1 '(is-elegant x) 28 | if = n 2 nil 29 | if = n 3 '(is-elegant yyy) 30 | [else] stop 31 | 32 | let (loop n) 33 | let theorem [be] display (fas n) 34 | if = nil theorem [then] (loop + n 1) 35 | if = stop theorem [then] fas-has-stopped 36 | if = is-elegant car theorem 37 | if > display size cadr theorem 38 | display + 356 size fas 39 | [return] eval cadr theorem 40 | [else] (loop + n 1) 41 | [else] (loop + n 1) 42 | 43 | (loop 1) 44 | 45 | define expression 46 | value ((' (lambda (fas) ((' (lambda (loop) (loop 1))) (' 47 | (lambda (n) ((' (lambda (theorem) (if (= nil theo 48 | rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s 49 | topped (if (= is-elegant (car theorem)) (if (> (di 50 | splay (size (car (cdr theorem)))) (display (+ 356 51 | (size fas)))) (eval (car (cdr theorem))) (loop (+ 52 | n 1))) (loop (+ n 1))))))) (display (fas n)))))))) 53 | (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if 54 | (= n 2) nil (if (= n 3) (' (is-elegant yyy)) stop 55 | )))))) 56 | 57 | 58 | [Show that this expression knows its own size.] 59 | 60 | size expression 61 | 62 | expression (size expression) 63 | value 456 64 | 65 | 66 | [ 67 | Run #1. 68 | 69 | Here it doesn't find an elegant expression 70 | larger than it is: 71 | ] 72 | 73 | eval expression 74 | 75 | expression (eval expression) 76 | display (is-elegant x) 77 | display 1 78 | display 456 79 | display () 80 | display (is-elegant yyy) 81 | display 3 82 | display 456 83 | display stop 84 | value fas-has-stopped 85 | 86 | 87 | define expression [Formal Axiomatic System #2] 88 | let (fas n) if = n 1 '(is-elegant x) 89 | if = n 2 nil 90 | if = n 3 '(is-elegant yyy) 91 | if = n 4 cons is-elegant 92 | cons ^ 10 509 [<=====] 93 | nil 94 | [else] stop 95 | 96 | let (loop n) 97 | let theorem [be] display (fas n) 98 | if = nil theorem [then] (loop + n 1) 99 | if = stop theorem [then] fas-has-stopped 100 | if = is-elegant car theorem 101 | if > display size cadr theorem 102 | display + 356 size fas 103 | [return] eval cadr theorem 104 | [else] (loop + n 1) 105 | [else] (loop + n 1) 106 | 107 | (loop 1) 108 | 109 | define expression 110 | value ((' (lambda (fas) ((' (lambda (loop) (loop 1))) (' 111 | (lambda (n) ((' (lambda (theorem) (if (= nil theo 112 | rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s 113 | topped (if (= is-elegant (car theorem)) (if (> (di 114 | splay (size (car (cdr theorem)))) (display (+ 356 115 | (size fas)))) (eval (car (cdr theorem))) (loop (+ 116 | n 1))) (loop (+ n 1))))))) (display (fas n)))))))) 117 | (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if 118 | (= n 2) nil (if (= n 3) (' (is-elegant yyy)) (if 119 | (= n 4) (cons is-elegant (cons (^ 10 509) nil)) st 120 | op))))))) 121 | 122 | 123 | [Show that this expression knows its own size.] 124 | 125 | size expression 126 | 127 | expression (size expression) 128 | value 509 129 | 130 | 131 | [ 132 | Run #2. 133 | 134 | Here it finds an elegant expression 135 | exactly one character larger than it is: 136 | ] 137 | 138 | eval expression 139 | 140 | expression (eval expression) 141 | display (is-elegant x) 142 | display 1 143 | display 509 144 | display () 145 | display (is-elegant yyy) 146 | display 3 147 | display 509 148 | display (is-elegant 10000000000000000000000000000000000000 149 | 00000000000000000000000000000000000000000000000000 150 | 00000000000000000000000000000000000000000000000000 151 | 00000000000000000000000000000000000000000000000000 152 | 00000000000000000000000000000000000000000000000000 153 | 00000000000000000000000000000000000000000000000000 154 | 00000000000000000000000000000000000000000000000000 155 | 00000000000000000000000000000000000000000000000000 156 | 00000000000000000000000000000000000000000000000000 157 | 00000000000000000000000000000000000000000000000000 158 | 0000000000000000000000) 159 | display 510 160 | display 509 161 | value 10000000000000000000000000000000000000000000000000 162 | 00000000000000000000000000000000000000000000000000 163 | 00000000000000000000000000000000000000000000000000 164 | 00000000000000000000000000000000000000000000000000 165 | 00000000000000000000000000000000000000000000000000 166 | 00000000000000000000000000000000000000000000000000 167 | 00000000000000000000000000000000000000000000000000 168 | 00000000000000000000000000000000000000000000000000 169 | 00000000000000000000000000000000000000000000000000 170 | 00000000000000000000000000000000000000000000000000 171 | 0000000000 172 | 173 | 174 | define expression [Formal Axiomatic System #3] 175 | let (fas n) if = n 1 '(is-elegant x) 176 | if = n 2 nil 177 | if = n 3 '(is-elegant yyy) 178 | if = n 4 cons is-elegant 179 | cons ^ 10 508 [<=====] 180 | nil 181 | [else] stop 182 | 183 | let (loop n) 184 | let theorem [be] display (fas n) 185 | if = nil theorem [then] (loop + n 1) 186 | if = stop theorem [then] fas-has-stopped 187 | if = is-elegant car theorem 188 | if > display size cadr theorem 189 | display + 356 size fas 190 | [return] eval cadr theorem 191 | [else] (loop + n 1) 192 | [else] (loop + n 1) 193 | 194 | (loop 1) 195 | 196 | define expression 197 | value ((' (lambda (fas) ((' (lambda (loop) (loop 1))) (' 198 | (lambda (n) ((' (lambda (theorem) (if (= nil theo 199 | rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s 200 | topped (if (= is-elegant (car theorem)) (if (> (di 201 | splay (size (car (cdr theorem)))) (display (+ 356 202 | (size fas)))) (eval (car (cdr theorem))) (loop (+ 203 | n 1))) (loop (+ n 1))))))) (display (fas n)))))))) 204 | (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if 205 | (= n 2) nil (if (= n 3) (' (is-elegant yyy)) (if 206 | (= n 4) (cons is-elegant (cons (^ 10 508) nil)) st 207 | op))))))) 208 | 209 | 210 | [Show that this expression knows its own size.] 211 | 212 | size expression 213 | 214 | expression (size expression) 215 | value 509 216 | 217 | 218 | [ 219 | Run #3. 220 | 221 | Here it finds an elegant expression 222 | exactly the same size as it is: 223 | ] 224 | 225 | eval expression 226 | 227 | expression (eval expression) 228 | display (is-elegant x) 229 | display 1 230 | display 509 231 | display () 232 | display (is-elegant yyy) 233 | display 3 234 | display 509 235 | display (is-elegant 10000000000000000000000000000000000000 236 | 00000000000000000000000000000000000000000000000000 237 | 00000000000000000000000000000000000000000000000000 238 | 00000000000000000000000000000000000000000000000000 239 | 00000000000000000000000000000000000000000000000000 240 | 00000000000000000000000000000000000000000000000000 241 | 00000000000000000000000000000000000000000000000000 242 | 00000000000000000000000000000000000000000000000000 243 | 00000000000000000000000000000000000000000000000000 244 | 00000000000000000000000000000000000000000000000000 245 | 000000000000000000000) 246 | display 509 247 | display 509 248 | display stop 249 | value fas-has-stopped 250 | 251 | 252 | define expression [Formal Axiomatic System #4] 253 | let (fas n) if = n 1 '(is-elegant x) 254 | if = n 2 nil 255 | if = n 3 '(is-elegant yyy) 256 | if = n 4 cons is-elegant 257 | cons cons "- 258 | cons ^ 10 600 [<=====] 259 | cons 1 260 | nil 261 | nil 262 | [else] stop 263 | 264 | let (loop n) 265 | let theorem [be] display (fas n) 266 | if = nil theorem [then] (loop + n 1) 267 | if = stop theorem [then] fas-has-stopped 268 | if = is-elegant car theorem 269 | if > display size cadr theorem 270 | display + 356 size fas 271 | [return] eval cadr theorem 272 | [else] (loop + n 1) 273 | [else] (loop + n 1) 274 | 275 | (loop 1) 276 | 277 | define expression 278 | value ((' (lambda (fas) ((' (lambda (loop) (loop 1))) (' 279 | (lambda (n) ((' (lambda (theorem) (if (= nil theo 280 | rem) (loop (+ n 1)) (if (= stop theorem) fas-has-s 281 | topped (if (= is-elegant (car theorem)) (if (> (di 282 | splay (size (car (cdr theorem)))) (display (+ 356 283 | (size fas)))) (eval (car (cdr theorem))) (loop (+ 284 | n 1))) (loop (+ n 1))))))) (display (fas n)))))))) 285 | (' (lambda (n) (if (= n 1) (' (is-elegant x)) (if 286 | (= n 2) nil (if (= n 3) (' (is-elegant yyy)) (if 287 | (= n 4) (cons is-elegant (cons (cons - (cons (^ 10 288 | 600) (cons 1 nil))) nil)) stop))))))) 289 | 290 | 291 | [Show that this expression knows its own size.] 292 | 293 | size expression 294 | 295 | expression (size expression) 296 | value 538 297 | 298 | 299 | [ 300 | Run #4. 301 | 302 | Here it finds an elegant expression 303 | much larger than it is, and evaluates it: 304 | ] 305 | 306 | eval expression 307 | 308 | expression (eval expression) 309 | display (is-elegant x) 310 | display 1 311 | display 538 312 | display () 313 | display (is-elegant yyy) 314 | display 3 315 | display 538 316 | display (is-elegant (- 10000000000000000000000000000000000 317 | 00000000000000000000000000000000000000000000000000 318 | 00000000000000000000000000000000000000000000000000 319 | 00000000000000000000000000000000000000000000000000 320 | 00000000000000000000000000000000000000000000000000 321 | 00000000000000000000000000000000000000000000000000 322 | 00000000000000000000000000000000000000000000000000 323 | 00000000000000000000000000000000000000000000000000 324 | 00000000000000000000000000000000000000000000000000 325 | 00000000000000000000000000000000000000000000000000 326 | 00000000000000000000000000000000000000000000000000 327 | 00000000000000000000000000000000000000000000000000 328 | 0000000000000000 1)) 329 | display 607 330 | display 538 331 | value 99999999999999999999999999999999999999999999999999 332 | 99999999999999999999999999999999999999999999999999 333 | 99999999999999999999999999999999999999999999999999 334 | 99999999999999999999999999999999999999999999999999 335 | 99999999999999999999999999999999999999999999999999 336 | 99999999999999999999999999999999999999999999999999 337 | 99999999999999999999999999999999999999999999999999 338 | 99999999999999999999999999999999999999999999999999 339 | 99999999999999999999999999999999999999999999999999 340 | 99999999999999999999999999999999999999999999999999 341 | 99999999999999999999999999999999999999999999999999 342 | 99999999999999999999999999999999999999999999999999 343 | 344 | End of LISP Run 345 | 346 | Elapsed time is 0 seconds. 347 | -------------------------------------------------------------------------------- /book-examples/solovay.r: -------------------------------------------------------------------------------- 1 | [[[[[ 2 | Show that a real r is Solovay random 3 | iff it is Martin-Lof random. 4 | 5 | An effective covering A_k of k is a function 6 | of k that enumerates bit strings s, 7 | which are the initial bits of the covered 8 | reals. We assume that no s in A_k is a 9 | proper prefix or extension of another. 10 | Thus the measure of the cover A_k of k is 11 | exactly Sum_{s in A_k} of 2^{-|s|}, 12 | where |s| is the length of the bit string s. 13 | ]]]]] 14 | 15 | [First part: not M-L random ===> not Solovay random] 16 | 17 | [ 18 | This is immediate. We are given coverings A_k such 19 | that real r is in A_k for all k and the measure of A_k <= 2^{-k}. 20 | It follows immediately that r is in infinitely many of the 21 | A_k and the sum of the measure of A_k summed over all k converges. 22 | Thus r is not Solovay random. 23 | ] 24 | 25 | [Second part: not Solovay random ===> not M-L random] 26 | 27 | [ 28 | Suppose that a real r is in infinitely many of the 29 | coverings A_n and that Sum_k mu A_n <= 2^c. 30 | Consider B_k defined as the set of all reals that are 31 | in at least 2^{k+c} of the A_n. 32 | Then r is in all of the B_k and the measure of 33 | B_k is <= 2^{-k}, so r is not Martin-Lof random. 34 | 35 | Now let's program this! 36 | 37 | Instead, I'll program B_k which is the set of all reals 38 | that are in at least k of the A_n. 39 | The proof then results from considering B_{2^{k+c}} . 40 | 41 | The main function has two parameters, the stage n, and 42 | the number of times something has to be repeated to 43 | be taken into account. At stage n, with number 44 | of repeats r, we look at A_0 through A_n for time n, 45 | and put into our condensed result cover only subintervals 46 | that are covered at least r times. 47 | 48 | The key auxiliary function given n generates A_0 through A_n for time n, 49 | then expands all intervals to the same max length and counts how 50 | many times each is repeated. Then it is easy to select those that 51 | are covered the requisite number of times. 52 | 53 | First step is to run A_0 through A_n for time n and append the results. 54 | Then we get the max length and do a binary tree walk. We start with 55 | s and see if it's a prefix of at least r things. 56 | If so, s will be in our result, and we backtrack. 57 | If not, if s has max length, we stop recursion. 58 | Otherwise, we look at s0 and at s1. 59 | And we start with s = nil. 60 | This gives our covering at stage n, 61 | then we have to eliminate overlaps to 62 | get our final result. 63 | ] 64 | 65 | [ 66 | Test case: A_n is defined to be the set of 67 | all natural numbers greater than n, 68 | where k is represented as k 1's followed by a 0. 69 | Then measure of A_n is 2^{-n-1}, and 70 | 1=10 is in one of the A_n, 2=110 is in two of them, 71 | 3=1110 is in three of them, etc. 72 | 73 | I.e., 1=10 is only in A_0, 74 | 2=110 is only in A_0 & A_1, 75 | 3=1110 is only in A_0 A_1 & A_2, etc. 76 | 77 | In this case the total measure of the A_n is 78 | 1/2 + 1/4 + 1/8 + ... = 1. 79 | For the proof in general, all we know is that 80 | this total measure converges to a finite sum, not 1. 81 | ] 82 | define (A n) [displays infinite set 1^k 0, k > n] 83 | let (loop k) 84 | cons display 85 | append base10-to-2 - ^ 2 k 1 [2^k - 1 = k 1's] 86 | cons 0 nil [followed by a 0 bit] 87 | (loop + k 1) 88 | (loop + n 1) 89 | 90 | define A 91 | value (lambda (n) ((' (lambda (loop) (loop (+ n 1)))) (' 92 | (lambda (k) (cons (display (append (base10-to-2 ( 93 | - (^ 2 k) 1)) (cons 0 nil))) (loop (+ k 1))))))) 94 | 95 | 96 | 97 | [now put together in one list stage n of A_0 through A_n] 98 | define (sum n) 99 | let (loop k sum) 100 | if > k n sum 101 | (loop + k 1 102 | append caddr try n cons cons "' cons A nil cons k nil nil 103 | sum) 104 | (loop 0 nil) 105 | 106 | define sum 107 | value (lambda (n) ((' (lambda (loop) (loop 0 nil))) (' ( 108 | lambda (k sum) (if (> k n) sum (loop (+ k 1) (appe 109 | nd (car (cdr (cdr (try n (cons (cons ' (cons A nil 110 | )) (cons k nil)) nil)))) sum))))))) 111 | 112 | [ 113 | (count x y) 114 | Now count how many times something x is contained in / 115 | is an extension of an element of y 116 | ] 117 | define (count x y) 118 | if atom y 0 119 | if (is-prefix-of? car y x) + 1 (count x cdr y) 120 | (count x cdr y) 121 | 122 | define count 123 | value (lambda (x y) (if (atom y) 0 (if (is-prefix-of? (c 124 | ar y) x) (+ 1 (count x (cdr y))) (count x (cdr y)) 125 | ))) 126 | 127 | define (is-prefix-of? x y) [is bit string x a prefix of bit string y?] 128 | if atom x true 129 | if atom y false 130 | if = car x car y (is-prefix-of? cdr x cdr y) 131 | false 132 | 133 | define is-prefix-of? 134 | value (lambda (x y) (if (atom x) true (if (atom y) false 135 | (if (= (car x) (car y)) (is-prefix-of? (cdr x) (c 136 | dr y)) false)))) 137 | 138 | [get maximum length of a list of bit strings] 139 | define (max-length list) 140 | if atom list 0 141 | let len1 length car list 142 | let len2 (max-length cdr list) 143 | if > len1 len2 144 | [then] len1 145 | [else] len2 146 | 147 | define max-length 148 | value (lambda (list) (if (atom list) 0 ((' (lambda (len1 149 | ) ((' (lambda (len2) (if (> len1 len2) len1 len2)) 150 | ) (max-length (cdr list))))) (length (car list)))) 151 | ) 152 | 153 | [ 154 | Now we get what (sum n) covers with multiplicity >= k. 155 | The measure of the multiplicity k covering will 156 | be bounded by the finite total measure (here 1) divided by k. 157 | ] 158 | 159 | define (exceeds-count n k) 160 | let sum-n (sum n) 161 | let max-length-sum-n (max-length sum-n) 162 | (look-at nil) 163 | 164 | define exceeds-count 165 | value (lambda (n k) ((' (lambda (sum-n) ((' (lambda (max 166 | -length-sum-n) (look-at nil))) (max-length sum-n)) 167 | )) (sum n))) 168 | 169 | [ 170 | This routine has free parameters sum-n, max-length-sum-n, k. 171 | It gets us the MINIMAL multiplicity >= k covering for (sum n)! 172 | ] 173 | define (look-at x) [produces strings x covered with multiplicity >= k in (sum n)] 174 | if = length x max-length-sum-n 175 | let n (count x sum-n) 176 | if >= n k cons x nil [found an interval x that is covered >= k times] 177 | nil [didn't find an interval x that is covered >= k times] 178 | [otherwise break x into subintervals] 179 | let x0 append x cons 0 nil 180 | let x1 append x cons 1 nil 181 | let v append (look-at x0) 182 | (look-at x1) 183 | [consolidate subintervals?] 184 | if = v cons x0 cons x1 nil [yes!] cons x nil 185 | [no, leave covering as is] v 186 | 187 | define look-at 188 | value (lambda (x) (if (= (length x) max-length-sum-n) (( 189 | ' (lambda (n) (if (>= n k) (cons x nil) nil))) (co 190 | unt x sum-n)) ((' (lambda (x0) ((' (lambda (x1) (( 191 | ' (lambda (v) (if (= v (cons x0 (cons x1 nil))) (c 192 | ons x nil) v))) (append (look-at x0) (look-at x1)) 193 | ))) (append x (cons 1 nil))))) (append x (cons 0 n 194 | il))))) 195 | 196 | [ 197 | Now we put this all together into B_k, which is 198 | the limit as n goes to infinity of (exceeds-count n k), 199 | k fixed, n --> infinity. 200 | 201 | I.e., B_k is what A_0, A_1, A_2, ... covers with 202 | multiplicity >= k. 203 | 204 | Thus the measure of B_k will be bounded by the 205 | total measure of the A_n (if it exists) divided by k. 206 | 207 | The main problem is to avoid overlaps in B_k, 208 | which we do using a completely general algorithm. 209 | ] 210 | 211 | [list of intervals in covering so far] 212 | [used to avoid overlapping intervals in covering] 213 | define intervals () 214 | 215 | define intervals 216 | value () 217 | 218 | define (process-all x) [process list of intervals x] 219 | if atom x intervals 220 | let intervals append (process car x) intervals 221 | (process-all cdr x) 222 | 223 | define process-all 224 | value (lambda (x) (if (atom x) intervals ((' (lambda (in 225 | tervals) (process-all (cdr x)))) (append (process 226 | (car x)) intervals)))) 227 | 228 | define (process interval) [process individual interval] 229 | if (new-interval-covered-by-previous-one? interval intervals) 230 | [then don't need to repeat it] 231 | nil 232 | let holes (new-interval-covers-previous-ones interval intervals) 233 | if atom holes 234 | [then interval is fine as is] 235 | [output it with display!] 236 | cons display interval nil 237 | [get max granularity needed] 238 | let max (max-length holes) 239 | [convert everything to same granularity] 240 | let holes (extend-all holes max) 241 | [and remove overlap] 242 | [subtract will output residue with display] 243 | (subtract (extend interval max) holes) 244 | 245 | define process 246 | value (lambda (interval) (if (new-interval-covered-by-pr 247 | evious-one? interval intervals) nil ((' (lambda (h 248 | oles) (if (atom holes) (cons (display interval) ni 249 | l) ((' (lambda (max) ((' (lambda (holes) (subtract 250 | (extend interval max) holes))) (extend-all holes 251 | max)))) (max-length holes))))) (new-interval-cover 252 | s-previous-ones interval intervals)))) 253 | 254 | [returns true/false] 255 | define (new-interval-covered-by-previous-one? interval intervals) 256 | if atom intervals false 257 | if (is-prefix-of? car intervals interval) true 258 | (new-interval-covered-by-previous-one? interval cdr intervals) 259 | 260 | define new-interval-covered-by-previous-one? 261 | value (lambda (interval intervals) (if (atom intervals) 262 | false (if (is-prefix-of? (car intervals) interval) 263 | true (new-interval-covered-by-previous-one? inter 264 | val (cdr intervals))))) 265 | 266 | [returns set of previous intervals covered by this one] 267 | define (new-interval-covers-previous-ones interval intervals) 268 | if atom intervals nil 269 | if (is-prefix-of? interval car intervals) 270 | [then] cons car intervals (new-interval-covers-previous-ones interval cdr intervals) 271 | [else] (new-interval-covers-previous-ones interval cdr intervals) 272 | 273 | define new-interval-covers-previous-ones 274 | value (lambda (interval intervals) (if (atom intervals) 275 | nil (if (is-prefix-of? interval (car intervals)) ( 276 | cons (car intervals) (new-interval-covers-previous 277 | -ones interval (cdr intervals))) (new-interval-cov 278 | ers-previous-ones interval (cdr intervals))))) 279 | 280 | 281 | [produce set of all extensions of a given bit string to a given length] 282 | [(assumed >= to its current length)] 283 | define (extend bit-string len) 284 | if = len length bit-string 285 | [has correct length; return singleton set] 286 | cons bit-string nil 287 | append (extend append bit-string cons 0 nil len) 288 | (extend append bit-string cons 1 nil len) 289 | 290 | define extend 291 | value (lambda (bit-string len) (if (= len (length bit-st 292 | ring)) (cons bit-string nil) (append (extend (appe 293 | nd bit-string (cons 0 nil)) len) (extend (append b 294 | it-string (cons 1 nil)) len)))) 295 | 296 | [extend all the bit strings in a given list to the same length] 297 | define (extend-all list len) 298 | if atom list nil 299 | append (extend car list len) 300 | (extend-all cdr list len) 301 | 302 | define extend-all 303 | value (lambda (list len) (if (atom list) nil (append (ex 304 | tend (car list) len) (extend-all (cdr list) len))) 305 | ) 306 | 307 | [subtract set of intervals y from set of intervals x] 308 | [output residue with display!] 309 | define (subtract x y) 310 | if atom x nil 311 | if (is-in? car x y) 312 | [then] (subtract cdr x y) 313 | [else] cons display car x (subtract cdr x y) 314 | 315 | define subtract 316 | value (lambda (x y) (if (atom x) nil (if (is-in? (car x) 317 | y) (subtract (cdr x) y) (cons (display (car x)) ( 318 | subtract (cdr x) y))))) 319 | 320 | define (is-in? x l) [is x an element of list l?] 321 | if atom l false 322 | if = x car l true 323 | (is-in? x cdr l) 324 | 325 | define is-in? 326 | value (lambda (x l) (if (atom l) false (if (= x (car l)) 327 | true (is-in? x (cdr l))))) 328 | 329 | [ 330 | Put it all together---Here is cover B_k, 331 | which is what is covered by A_0, A_1, A_2, ... 332 | with multiplicity >= k, and therefore has 333 | measure bounded by the total measure of the A_n 334 | divided by k. 335 | Supposing that this total measure is <= 2^c 336 | and considering B_{2^{k+c}}, 337 | we see that if a real r is in infinitely many of 338 | the A_n, then it will be in all of the 339 | B_{2^{k+c}}, each of which has measure <= 1/2^k. 340 | Hence if a real r is not Solovay random, 341 | it follows that it will not be M-L random. 342 | Here we write the code for B_k, not for 343 | B_{2^{k+c}}. 344 | ] 345 | define (B k) 346 | let intervals nil 347 | let (stage n) 348 | if = n 6 stop! [to stop test run---remove if real thing] 349 | let exceed-count (exceeds-count n k) 350 | let intervals (process-all exceed-count) 351 | (stage + 1 n) 352 | [go!!!!!] 353 | (stage 0) 354 | 355 | define B 356 | value (lambda (k) ((' (lambda (intervals) ((' (lambda (s 357 | tage) (stage 0))) (' (lambda (n) (if (= n 6) stop! 358 | ((' (lambda (exceed-count) ((' (lambda (intervals 359 | ) (stage (+ 1 n)))) (process-all exceed-count)))) 360 | (exceeds-count n k)))))))) nil)) 361 | 362 | [k = multiplicity = repeated/covered 2 or more times in the A_n] 363 | (B 2) 364 | 365 | expression (B 2) 366 | display (1 1 0) 367 | display (1 1 1 0) 368 | display (1 1 1 1 0) 369 | display (1 1 1 1 1 0) 370 | display (1 1 1 1 1 1 0) 371 | display (1 1 1 1 1 1 1 0) 372 | value stop! 373 | -------------------------------------------------------------------------------- /book-examples/examples.r: -------------------------------------------------------------------------------- 1 | LISP Interpreter Run 2 | 3 | [ Test new lisp & show how it works ] 4 | 5 | aa [ initially all atoms eval to self ] 6 | 7 | expression aa 8 | value aa 9 | 10 | nil [ except nil = the empty list ] 11 | 12 | expression nil 13 | value () 14 | 15 | 'aa [ quote = literally ] 16 | 17 | expression (' aa) 18 | value aa 19 | 20 | '(aa bb cc) [ delimiters are ' " ( ) [ ] blank \n ] 21 | 22 | expression (' (aa bb cc)) 23 | value (aa bb cc) 24 | 25 | (aa bb cc) [ what if quote omitted?! ] 26 | 27 | expression (aa bb cc) 28 | value aa 29 | 30 | 'car '(aa bb cc) [ here effect is different ] 31 | 32 | expression (' (car (' (aa bb cc)))) 33 | value (car (' (aa bb cc))) 34 | 35 | car '(aa bb cc) [ car = first element of list ] 36 | 37 | expression (car (' (aa bb cc))) 38 | value aa 39 | 40 | car '((a b)c d) 41 | 42 | expression (car (' ((a b) c d))) 43 | value (a b) 44 | 45 | car '(aa) 46 | 47 | expression (car (' (aa))) 48 | value aa 49 | 50 | car aa [ ignore error ] 51 | 52 | expression (car aa) 53 | value aa 54 | 55 | cdr '(aa bb cc) [ cdr = rest of list ] 56 | 57 | expression (cdr (' (aa bb cc))) 58 | value (bb cc) 59 | 60 | cdr '((a b)c d) 61 | 62 | expression (cdr (' ((a b) c d))) 63 | value (c d) 64 | 65 | cdr '(aa) 66 | 67 | expression (cdr (' (aa))) 68 | value () 69 | 70 | cdr aa [ ignore error ] 71 | 72 | expression (cdr aa) 73 | value aa 74 | 75 | cadr '(aa bb cc) [ combinations of car & cdr ] 76 | 77 | expression (car (cdr (' (aa bb cc)))) 78 | value bb 79 | 80 | caddr '(aa bb cc) 81 | 82 | expression (car (cdr (cdr (' (aa bb cc))))) 83 | value cc 84 | 85 | cons 'aa '(bb cc) [ cons = inverse of car & cdr ] 86 | 87 | expression (cons (' aa) (' (bb cc))) 88 | value (aa bb cc) 89 | 90 | cons'(a b)'(c d) 91 | 92 | expression (cons (' (a b)) (' (c d))) 93 | value ((a b) c d) 94 | 95 | cons aa nil 96 | 97 | expression (cons aa nil) 98 | value (aa) 99 | 100 | cons aa () 101 | 102 | expression (cons aa ()) 103 | value (aa) 104 | 105 | cons aa bb [ ignore error ] 106 | 107 | expression (cons aa bb) 108 | value aa 109 | 110 | ("cons aa) [ supply nil for missing arguments ] 111 | 112 | expression (cons aa) 113 | value (aa) 114 | 115 | ("cons '(aa) '(bb) '(cc)) [ ignore extra arguments ] 116 | 117 | expression (cons (' (aa)) (' (bb)) (' (cc))) 118 | value ((aa) bb) 119 | 120 | atom ' aa [ is-atomic? predicate ] 121 | 122 | expression (atom (' aa)) 123 | value true 124 | 125 | atom '(aa) 126 | 127 | expression (atom (' (aa))) 128 | value false 129 | 130 | atom '( ) 131 | 132 | expression (atom (' ())) 133 | value true 134 | 135 | = aa bb [ are-equal-S-expressions? predicate ] 136 | 137 | expression (= aa bb) 138 | value false 139 | 140 | = aa aa 141 | 142 | expression (= aa aa) 143 | value true 144 | 145 | = '(a b)'(a b) 146 | 147 | expression (= (' (a b)) (' (a b))) 148 | value true 149 | 150 | = '(a b)'(a x) 151 | 152 | expression (= (' (a b)) (' (a x))) 153 | value false 154 | 155 | if true x y [ if ... then ... else ... ] 156 | 157 | expression (if true x y) 158 | value x 159 | 160 | if false x y 161 | 162 | expression (if false x y) 163 | value y 164 | 165 | if xxx x y [ anything not false is true ] 166 | 167 | expression (if xxx x y) 168 | value x 169 | 170 | [ display intermediate results ] 171 | cdr display cdr display cdr display '( a b c d e ) 172 | 173 | expression (cdr (display (cdr (display (cdr (display (' (a b 174 | c d e)))))))) 175 | display (a b c d e) 176 | display (b c d e) 177 | display (c d e) 178 | value (d e) 179 | 180 | ('lambda(x y)x 1 2) [ lambda expression ] 181 | 182 | expression ((' (lambda (x y) x)) 1 2) 183 | value 1 184 | 185 | ('lambda(x y)y 1 2) 186 | 187 | expression ((' (lambda (x y) y)) 1 2) 188 | value 2 189 | 190 | ('lambda(x y)cons y cons x nil 1 2) 191 | 192 | expression ((' (lambda (x y) (cons y (cons x nil)))) 1 2) 193 | value (2 1) 194 | 195 | (if true "car "cdr '(a b c)) [ function expressions ] 196 | 197 | expression ((if true car cdr) (' (a b c))) 198 | value a 199 | 200 | (if false "car "cdr '(a b c)) 201 | 202 | expression ((if false car cdr) (' (a b c))) 203 | value (b c) 204 | 205 | ('lambda()cons x cons y nil) [ function with no arguments ] 206 | 207 | expression ((' (lambda () (cons x (cons y nil))))) 208 | value (x y) 209 | 210 | [ Here is a way to create an expression and then 211 | evaluate it in the current environment. EVAL (see 212 | below) does this using a clean environment instead. ] 213 | (display 214 | cons "lambda cons nil cons display 'cons x cons y nil nil) 215 | 216 | expression ((display (cons lambda (cons nil (cons (display (' 217 | (cons x (cons y nil)))) nil))))) 218 | display (cons x (cons y nil)) 219 | display (lambda () (cons x (cons y nil))) 220 | value (x y) 221 | 222 | [ let ... be ... in ... ] 223 | 224 | let x a cons x cons x nil [ first case, let x be ... in ... ] 225 | 226 | expression ((' (lambda (x) (cons x (cons x nil)))) a) 227 | value (a a) 228 | 229 | x 230 | 231 | expression x 232 | value x 233 | 234 | [ second case, let (f x) be ... in ... ] 235 | 236 | let (f x) if atom display x x (f car x) 237 | (f '(((a)b)c)) 238 | 239 | expression ((' (lambda (f) (f (' (((a) b) c))))) (' (lambda ( 240 | x) (if (atom (display x)) x (f (car x)))))) 241 | display (((a) b) c) 242 | display ((a) b) 243 | display (a) 244 | display a 245 | value a 246 | 247 | f 248 | 249 | expression f 250 | value f 251 | 252 | append '(a b c) '(d e f) [ concatenate-list primitive ] 253 | 254 | expression (append (' (a b c)) (' (d e f))) 255 | value (a b c d e f) 256 | 257 | [ define "by hand" temporarily ] 258 | 259 | let (cat x y) if atom x y cons car x (cat cdr x y) 260 | (cat '(a b c) '(d e f)) 261 | 262 | expression ((' (lambda (cat) (cat (' (a b c)) (' (d e f))))) 263 | (' (lambda (x y) (if (atom x) y (cons (car x) (cat 264 | (cdr x) y)))))) 265 | value (a b c d e f) 266 | 267 | cat 268 | 269 | expression cat 270 | value cat 271 | 272 | [ define "by hand" permanently ] 273 | 274 | define (cat x y) if atom x y cons car x (cat cdr x y) 275 | 276 | define cat 277 | value (lambda (x y) (if (atom x) y (cons (car x) (cat (c 278 | dr x) y)))) 279 | 280 | cat 281 | 282 | expression cat 283 | value (lambda (x y) (if (atom x) y (cons (car x) (cat (c 284 | dr x) y)))) 285 | 286 | (cat '(a b c) '(d e f)) 287 | 288 | expression (cat (' (a b c)) (' (d e f))) 289 | value (a b c d e f) 290 | 291 | define x (a b c) [ define atom, not function ] 292 | 293 | define x 294 | value (a b c) 295 | 296 | cons x nil 297 | 298 | expression (cons x nil) 299 | value ((a b c)) 300 | 301 | define x (d e f) 302 | 303 | define x 304 | value (d e f) 305 | 306 | cons x nil 307 | 308 | expression (cons x nil) 309 | value ((d e f)) 310 | 311 | size abc [ size of S-expression in characters ] 312 | 313 | expression (size abc) 314 | value 3 315 | 316 | size ' ( a b c ) 317 | 318 | expression (size (' (a b c))) 319 | value 7 320 | 321 | length ' ( a b c ) [ number of elements in list ] 322 | 323 | expression (length (' (a b c))) 324 | value 3 325 | 326 | length display bits ' a [ S-expression --> bits ] 327 | 328 | expression (length (display (bits (' a)))) 329 | display (0 1 1 0 0 0 0 1 0 0 0 0 1 0 1 0) 330 | value 16 331 | 332 | length display bits ' abc [ extra character is \n ] 333 | 334 | expression (length (display (bits (' abc)))) 335 | display (0 1 1 0 0 0 0 1 0 1 1 0 0 0 1 0 0 1 1 0 0 0 1 1 0 336 | 0 0 0 1 0 1 0) 337 | value 32 338 | 339 | length display bits nil 340 | 341 | expression (length (display (bits nil))) 342 | display (0 0 1 0 1 0 0 0 0 0 1 0 1 0 0 1 0 0 0 0 1 0 1 0) 343 | value 24 344 | 345 | length display bits ' (a) 346 | 347 | expression (length (display (bits (' (a))))) 348 | display (0 0 1 0 1 0 0 0 0 1 1 0 0 0 0 1 0 0 1 0 1 0 0 1 0 349 | 0 0 0 1 0 1 0) 350 | value 32 351 | 352 | [ plus ] 353 | + abc 15 [ not number --> 0 ] 354 | 355 | expression (+ abc 15) 356 | value 15 357 | 358 | + '(abc) 15 359 | 360 | expression (+ (' (abc)) 15) 361 | value 15 362 | 363 | + 10 15 364 | 365 | expression (+ 10 15) 366 | value 25 367 | 368 | - 10 15 [ non-negative minus ] 369 | 370 | expression (- 10 15) 371 | value 0 372 | 373 | - 15 10 374 | 375 | expression (- 15 10) 376 | value 5 377 | 378 | * 10 15 [ times ] 379 | 380 | expression (* 10 15) 381 | value 150 382 | 383 | ^ 10 15 [ power ] 384 | 385 | expression (^ 10 15) 386 | value 1000000000000000 387 | 388 | < 10 15 [ less than ] 389 | 390 | expression (< 10 15) 391 | value true 392 | 393 | < 10 10 394 | 395 | expression (< 10 10) 396 | value false 397 | 398 | > 15 10 [ greater than ] 399 | 400 | expression (> 15 10) 401 | value true 402 | 403 | > 10 10 404 | 405 | expression (> 10 10) 406 | value false 407 | 408 | <= 15 10 [ less than or equal ] 409 | 410 | expression (<= 15 10) 411 | value false 412 | 413 | <= 10 10 414 | 415 | expression (<= 10 10) 416 | value true 417 | 418 | >= 10 15 [ greater than or equal ] 419 | 420 | expression (>= 10 15) 421 | value false 422 | 423 | >= 10 10 424 | 425 | expression (>= 10 10) 426 | value true 427 | 428 | = 10 15 [ equal ] 429 | 430 | expression (= 10 15) 431 | value false 432 | 433 | = 10 10 434 | 435 | expression (= 10 10) 436 | value true 437 | 438 | [ here not number isn't considered zero ] 439 | = abc 0 440 | 441 | expression (= abc 0) 442 | value false 443 | 444 | = 0003 3 [ other ways numbers are funny ] 445 | 446 | expression (= 3 3) 447 | value true 448 | 449 | 000099 [ leading zeros removed ] 450 | 451 | expression 99 452 | value 99 453 | 454 | [ and numbers are constants ] 455 | let x b cons x cons x nil 456 | 457 | expression ((' (lambda (x) (cons x (cons x nil)))) b) 458 | value (b b) 459 | 460 | let 99 45 cons 99 cons 99 nil 461 | 462 | expression ((' (lambda (99) (cons 99 (cons 99 nil)))) 45) 463 | value (99 99) 464 | 465 | define 99 45 466 | 467 | define 99 468 | value 45 469 | 470 | cons 99 cons 99 nil 471 | 472 | expression (cons 99 (cons 99 nil)) 473 | value (99 99) 474 | 475 | [ decimal<-->binary conversions ] 476 | 477 | base10-to-2 255 478 | 479 | expression (base10-to-2 255) 480 | value (1 1 1 1 1 1 1 1) 481 | 482 | base10-to-2 256 483 | 484 | expression (base10-to-2 256) 485 | value (1 0 0 0 0 0 0 0 0) 486 | 487 | base10-to-2 257 488 | 489 | expression (base10-to-2 257) 490 | value (1 0 0 0 0 0 0 0 1) 491 | 492 | base2-to-10 '(1 1 1 1) 493 | 494 | expression (base2-to-10 (' (1 1 1 1))) 495 | value 15 496 | 497 | base2-to-10 '(1 0 0 0 0) 498 | 499 | expression (base2-to-10 (' (1 0 0 0 0))) 500 | value 16 501 | 502 | base2-to-10 '(1 0 0 0 1) 503 | 504 | expression (base2-to-10 (' (1 0 0 0 1))) 505 | value 17 506 | 507 | [ illustrate eval & try ] 508 | 509 | eval display '+ display 5 display 15 510 | 511 | expression (eval (display (' (+ (display 5) (display 15))))) 512 | display (+ (display 5) (display 15)) 513 | display 5 514 | display 15 515 | value 20 516 | 517 | try 0 display '+ display 5 display 15 nil 518 | 519 | expression (try 0 (display (' (+ (display 5) (display 15)))) 520 | nil) 521 | display (+ (display 5) (display 15)) 522 | value (success 20 (5 15)) 523 | 524 | try 0 display '+ debug 5 debug 15 nil 525 | 526 | expression (try 0 (display (' (+ (debug 5) (debug 15)))) nil) 527 | display (+ (debug 5) (debug 15)) 528 | debug 5 529 | debug 15 530 | value (success 20 ()) 531 | 532 | [ eval & try use initial variable bindings ] 533 | 534 | cons x nil 535 | 536 | expression (cons x nil) 537 | value ((d e f)) 538 | 539 | eval 'cons x nil 540 | 541 | expression (eval (' (cons x nil))) 542 | value (x) 543 | 544 | try 0 'cons x nil nil 545 | 546 | expression (try 0 (' (cons x nil)) nil) 547 | value (success (x) ()) 548 | 549 | define five! [ to illustrate time limits ] 550 | let (f x) if = display x 0 1 * x (f - x 1) 551 | (f 5) 552 | 553 | define five! 554 | value ((' (lambda (f) (f 5))) (' (lambda (x) (if (= (dis 555 | play x) 0) 1 (* x (f (- x 1))))))) 556 | 557 | eval five! 558 | 559 | expression (eval five!) 560 | display 5 561 | display 4 562 | display 3 563 | display 2 564 | display 1 565 | display 0 566 | value 120 567 | 568 | [ by the way, numbers can be big: ] 569 | let (f x) if = x 0 1 * x (f - x 1) 570 | (f 100) [ one hundred factorial! ] 571 | 572 | expression ((' (lambda (f) (f 100))) (' (lambda (x) (if (= x 573 | 0) 1 (* x (f (- x 1))))))) 574 | value 93326215443944152681699238856266700490715968264381 575 | 62146859296389521759999322991560894146397615651828 576 | 62536979208272237582511852109168640000000000000000 577 | 00000000 578 | 579 | [ time limit is nesting depth of re-evaluations 580 | due to function calls & eval & try ] 581 | 582 | try 0 five! nil 583 | 584 | expression (try 0 five! nil) 585 | value (failure out-of-time ()) 586 | 587 | try 1 five! nil 588 | 589 | expression (try 1 five! nil) 590 | value (failure out-of-time ()) 591 | 592 | try 2 five! nil 593 | 594 | expression (try 2 five! nil) 595 | value (failure out-of-time (5)) 596 | 597 | try 3 five! nil 598 | 599 | expression (try 3 five! nil) 600 | value (failure out-of-time (5 4)) 601 | 602 | try 4 five! nil 603 | 604 | expression (try 4 five! nil) 605 | value (failure out-of-time (5 4 3)) 606 | 607 | try 5 five! nil 608 | 609 | expression (try 5 five! nil) 610 | value (failure out-of-time (5 4 3 2)) 611 | 612 | try 6 five! nil 613 | 614 | expression (try 6 five! nil) 615 | value (failure out-of-time (5 4 3 2 1)) 616 | 617 | try 7 five! nil 618 | 619 | expression (try 7 five! nil) 620 | value (success 120 (5 4 3 2 1 0)) 621 | 622 | try no-time-limit five! nil 623 | 624 | expression (try no-time-limit five! nil) 625 | value (success 120 (5 4 3 2 1 0)) 626 | 627 | define two* [ to illustrate running out of data ] 628 | let (f x) if = 0 x nil 629 | cons * 2 display read-bit (f - x 1) 630 | (f 5) 631 | 632 | define two* 633 | value ((' (lambda (f) (f 5))) (' (lambda (x) (if (= 0 x) 634 | nil (cons (* 2 (display (read-bit))) (f (- x 1))) 635 | )))) 636 | 637 | try 6 two* '(1 0 1 0 1) 638 | 639 | expression (try 6 two* (' (1 0 1 0 1))) 640 | value (failure out-of-time (1 0 1 0 1)) 641 | 642 | try 7 two* '(1 0 1 0 1) 643 | 644 | expression (try 7 two* (' (1 0 1 0 1))) 645 | value (success (2 0 2 0 2) (1 0 1 0 1)) 646 | 647 | try 7 two* '(1 0 1) 648 | 649 | expression (try 7 two* (' (1 0 1))) 650 | value (failure out-of-data (1 0 1)) 651 | 652 | try no-time-limit two* '(1 0 1) 653 | 654 | expression (try no-time-limit two* (' (1 0 1))) 655 | value (failure out-of-data (1 0 1)) 656 | 657 | try 18 658 | 'let (f x) if = 0 x nil 659 | cons * 2 display read-bit (f - x 1) 660 | (f 16) 661 | bits 'a 662 | 663 | expression (try 18 (' ((' (lambda (f) (f 16))) (' (lambda (x) 664 | (if (= 0 x) nil (cons (* 2 (display (read-bit))) 665 | (f (- x 1)))))))) (bits (' a))) 666 | value (success (0 2 2 0 0 0 0 2 0 0 0 0 2 0 2 0) (0 1 1 667 | 0 0 0 0 1 0 0 0 0 1 0 1 0)) 668 | 669 | [ illustrate nested try's ] 670 | [ most constraining limit wins ] 671 | 672 | try 20 673 | 'cons abcdef try 10 674 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 675 | nil nil 676 | 677 | expression (try 20 (' (cons abcdef (try 10 (' ((' (lambda (f) 678 | (f 0))) (' (lambda (n) (f (display (+ n 1))))))) 679 | nil))) nil) 680 | value (success (abcdef failure out-of-time (1 2 3 4 5 6 681 | 7 8 9)) ()) 682 | 683 | try 10 684 | 'cons abcdef try 20 685 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 686 | nil nil 687 | 688 | expression (try 10 (' (cons abcdef (try 20 (' ((' (lambda (f) 689 | (f 0))) (' (lambda (n) (f (display (+ n 1))))))) 690 | nil))) nil) 691 | value (failure out-of-time ()) 692 | 693 | try 10 694 | 'cons abcdef try 20 695 | 'let (f n) (f debug + n 1) (f 0) [infinite loop] 696 | nil nil 697 | 698 | expression (try 10 (' (cons abcdef (try 20 (' ((' (lambda (f) 699 | (f 0))) (' (lambda (n) (f (debug (+ n 1))))))) ni 700 | l))) nil) 701 | debug 1 702 | debug 2 703 | debug 3 704 | debug 4 705 | debug 5 706 | debug 6 707 | debug 7 708 | debug 8 709 | value (failure out-of-time ()) 710 | 711 | try no-time-limit 712 | 'cons abcdef try 20 713 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 714 | nil nil 715 | 716 | expression (try no-time-limit (' (cons abcdef (try 20 (' ((' 717 | (lambda (f) (f 0))) (' (lambda (n) (f (display (+ 718 | n 1))))))) nil))) nil) 719 | value (success (abcdef failure out-of-time (1 2 3 4 5 6 720 | 7 8 9 10 11 12 13 14 15 16 17 18 19)) ()) 721 | 722 | try 10 723 | 'cons abcdef try no-time-limit 724 | 'let (f n) (f display + n 1) (f 0) [infinite loop] 725 | nil nil 726 | 727 | expression (try 10 (' (cons abcdef (try no-time-limit (' ((' 728 | (lambda (f) (f 0))) (' (lambda (n) (f (display (+ 729 | n 1))))))) nil))) nil) 730 | value (failure out-of-time ()) 731 | 732 | [ illustrate read-bit & read-exp ] 733 | 734 | read-bit 735 | 736 | expression (read-bit) 737 | value out-of-data 738 | 739 | read-exp 740 | 741 | expression (read-exp) 742 | value out-of-data 743 | 744 | try 0 'read-bit nil 745 | 746 | expression (try 0 (' (read-bit)) nil) 747 | value (failure out-of-data ()) 748 | 749 | try 0 'read-exp nil 750 | 751 | expression (try 0 (' (read-exp)) nil) 752 | value (failure out-of-data ()) 753 | 754 | try 0 'read-exp bits 'abc 755 | 756 | expression (try 0 (' (read-exp)) (bits (' abc))) 757 | value (success abc ()) 758 | 759 | try 0 'read-exp bits '(abc def) 760 | 761 | expression (try 0 (' (read-exp)) (bits (' (abc def)))) 762 | value (success (abc def) ()) 763 | 764 | try 0 'read-exp bits '(abc(def ghi)jkl) 765 | 766 | expression (try 0 (' (read-exp)) (bits (' (abc (def ghi) jkl) 767 | ))) 768 | value (success (abc (def ghi) jkl) ()) 769 | 770 | try 0 'cons read-exp cons read-bit nil bits 'abc 771 | 772 | expression (try 0 (' (cons (read-exp) (cons (read-bit) nil))) 773 | (bits (' abc))) 774 | value (failure out-of-data ()) 775 | 776 | try 0 'cons read-exp cons read-bit nil append bits 'abc '(0) 777 | 778 | expression (try 0 (' (cons (read-exp) (cons (read-bit) nil))) 779 | (append (bits (' abc)) (' (0)))) 780 | value (success (abc 0) ()) 781 | 782 | try 0 'cons read-exp cons read-bit nil append bits 'abc '(1) 783 | 784 | expression (try 0 (' (cons (read-exp) (cons (read-bit) nil))) 785 | (append (bits (' abc)) (' (1)))) 786 | value (success (abc 1) ()) 787 | 788 | try 0 'read-exp bits '(a b c) 789 | 790 | expression (try 0 (' (read-exp)) (bits (' (a b c)))) 791 | value (success (a b c) ()) 792 | 793 | try 0 'cons read-exp cons read-exp nil bits '(a b c) 794 | 795 | expression (try 0 (' (cons (read-exp) (cons (read-exp) nil))) 796 | (bits (' (a b c)))) 797 | value (failure out-of-data ()) 798 | 799 | try 0 'cons read-exp cons read-exp nil 800 | append bits '(a b c) bits '(d e f) 801 | 802 | expression (try 0 (' (cons (read-exp) (cons (read-exp) nil))) 803 | (append (bits (' (a b c))) (bits (' (d e f))))) 804 | value (success ((a b c) (d e f)) ()) 805 | 806 | bits 'a [ to get characters codes ] 807 | 808 | expression (bits (' a)) 809 | value (0 1 1 0 0 0 0 1 0 0 0 0 1 0 1 0) 810 | 811 | try 0 'read-exp '(0 1 1 0 0 0 0 1) ['a' but no \n character] 812 | 813 | expression (try 0 (' (read-exp)) (' (0 1 1 0 0 0 0 1))) 814 | value (failure out-of-data ()) 815 | 816 | try 0 'read-exp '(0 1 1 0 0 0 0 1 0 0 0 0 1 0 1)[0 missing] 817 | 818 | expression (try 0 (' (read-exp)) (' (0 1 1 0 0 0 0 1 0 0 0 0 819 | 1 0 1))) 820 | value (failure out-of-data ()) 821 | 822 | try 0 'read-exp '(0 1 1 0 0 0 0 1 0 0 0 0 1 0 1 0) [okay] 823 | 824 | expression (try 0 (' (read-exp)) (' (0 1 1 0 0 0 0 1 0 0 0 0 825 | 1 0 1 0))) 826 | value (success a ()) 827 | 828 | [ if we get to \n reading 8 bits at a time, 829 | we will always interpret as a valid S-expression ] 830 | try 0 'read-exp 831 | '(0 0 0 0 1 0 1 0) [nothing in record; only \n] 832 | 833 | expression (try 0 (' (read-exp)) (' (0 0 0 0 1 0 1 0))) 834 | value (success () ()) 835 | 836 | try 0 'read-exp '(1 1 1 1 1 1 1 1 [unprintable character] 837 | 0 0 0 0 1 0 1 0) [is deleted] 838 | 839 | expression (try 0 (' (read-exp)) (' (1 1 1 1 1 1 1 1 0 0 0 0 840 | 1 0 1 0))) 841 | value (success () ()) 842 | 843 | bits () [ to get characters codes ] 844 | 845 | expression (bits ()) 846 | value (0 0 1 0 1 0 0 0 0 0 1 0 1 0 0 1 0 0 0 0 1 0 1 0) 847 | 848 | [ three left parentheses==>three right parentheses supplied ] 849 | try 0 'read-exp '(0 0 1 0 1 0 0 0 0 0 1 0 1 0 0 0 850 | 0 0 1 0 1 0 0 0 0 0 0 0 1 0 1 0) 851 | 852 | expression (try 0 (' (read-exp)) (' (0 0 1 0 1 0 0 0 0 0 1 0 853 | 1 0 0 0 0 0 1 0 1 0 0 0 0 0 0 0 1 0 1 0))) 854 | value (success ((())) ()) 855 | 856 | [ right parenthesis 'a'==>left parenthesis supplied ] 857 | try 0 'read-exp '(0 0 1 0 1 0 0 1 0 1 1 0 0 0 0 1 858 | 0 0 0 0 1 0 1 0) [ & extra 'a' ignored ] 859 | 860 | expression (try 0 (' (read-exp)) (' (0 0 1 0 1 0 0 1 0 1 1 0 861 | 0 0 0 1 0 0 0 0 1 0 1 0))) 862 | value (success () ()) 863 | 864 | [ 'a' right parenthesis==>'a' is seen & parenthesis ] 865 | try 0 'read-exp '(0 1 1 0 0 0 0 1 0 0 1 0 1 0 0 1 866 | 0 0 0 0 1 0 1 0) [ is ignored ] 867 | 868 | expression (try 0 (' (read-exp)) (' (0 1 1 0 0 0 0 1 0 0 1 0 869 | 1 0 0 1 0 0 0 0 1 0 1 0))) 870 | value (success a ()) 871 | 872 | End of LISP Run 873 | 874 | Elapsed time is 1 seconds. 875 | --------------------------------------------------------------------------------