commit 04387c32ea0dc115fcc995e772dcdea182c3293a
Author: quantumish <freifeld.david@gmail.com>
Date: Mon, 13 Jul 2026 21:21:37 +0100
Initial commit
Diffstat:
| A | README | | | 3 | +++ |
| A | gap.c | | | 174 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | prob.lisp | | | 169 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | regex.lisp | | | 100 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | ropes.sml | | | 71 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | stack.lisp | | | 166 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | turing.sml | | | 163 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
7 files changed, 846 insertions(+), 0 deletions(-)
diff --git a/README b/README
@@ -0,0 +1,3 @@
+Some of the more polished examples of random programs I've written
+throughout the years. Each file begins with an editor's note with some
+extra context about what the program was for.
diff --git a/gap.c b/gap.c
@@ -0,0 +1,174 @@
+/**
+ * Editor's note: A simple program that demonstrates how a gap buffer works.
+ * I wrote this in order to have a visual demo for my 15-122 TA interview!
+ *
+ * Fun fact (and another demo I did during my interview): you can see how a
+ * gap buffer is used in Emacs by calling the functions (gap-position) and
+ * (gap-size). I recommend using the `lively` package to see how they
+ * update as you edit the buffer.
+ */
+
+#include <stddef.h>
+#include <stdbool.h>
+#include <assert.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+
+#define abs(x) ((x > 0) ? x : -x)
+
+#define REQUIRES(expr) assert(expr)
+#define ENSURES(expr) assert(expr)
+
+struct gap_buf {
+ char* buf;
+ size_t size;
+ size_t gap_start;
+ size_t gap_size;
+};
+
+typedef struct gap_buf* gapbuf_t;
+
+bool gb_gap_in_bounds(gapbuf_t gb, size_t gap_start) {
+ return (gap_start <= gb->size) &&
+ (gap_start + gb->gap_size) <= gb->size;
+}
+
+bool is_gap_buf(gapbuf_t gb) {
+ if (gb == NULL) return false;
+
+ bool buf_nonnull = gb->buf != NULL;
+ bool gap_in_bounds = gb_gap_in_bounds(gb, gb->gap_start);
+ // Redundant, but nice to be explicit
+ bool gap_size_sane = (gb->gap_size <= gb->size);
+
+ return buf_nonnull && gap_in_bounds && gap_size_sane;
+}
+
+gapbuf_t gb_new(size_t size) {
+ gapbuf_t out = malloc(sizeof(struct gap_buf));
+ out->buf = malloc(sizeof(char)*size);
+ out->size = size;
+ out->gap_start = 0;
+ out->gap_size = size;
+ ENSURES(is_gap_buf(out));
+ return out;
+}
+
+char* gb_start(const gapbuf_t gb) {
+ return gb->buf + gb->gap_start;
+}
+
+char* gb_end(const gapbuf_t gb) {
+ return gb->buf + gb->gap_start + gb->gap_size;
+}
+
+void gb_resize(gapbuf_t gb) { // O(n)
+ REQUIRES(is_gap_buf(gb));
+ gb->gap_size = gb->size;
+ gb->size *= 2;
+
+ char* old = gb->buf;
+ gb->buf = malloc(sizeof(char)*gb->size);
+ memcpy(gb->buf, old, gb->size/2);
+ memcpy(gb_end(gb), gb->buf + gb->gap_start,
+ gb->size/2 - gb->gap_start);
+ free(old);
+ ENSURES(gb->gap_size != 0);
+ ENSURES(is_gap_buf(gb));
+}
+
+void gb_print(gapbuf_t gb) {
+ REQUIRES(is_gap_buf(gb));
+ for (size_t i = 0; i < gb->size; i++) {
+ char* ptr = gb->buf + i;
+
+ if (i == gb->gap_start) {
+ if (gb->gap_size == 1) printf("[]");
+ else printf("[");
+ } else if (i == gb->gap_start + gb->gap_size - 1) {
+ printf(" ]");
+ } else if (i > gb->gap_start &&
+ i < gb->gap_start + gb->gap_size - 1) {
+ printf(" ");
+ } else {
+ printf("%c", *ptr);
+ }
+ }
+ printf("\n");
+}
+
+void gb_insert(gapbuf_t gb, char c) { // O(1) amt
+ REQUIRES(is_gap_buf(gb));
+ gb->buf[gb->gap_start] = c;
+ gb->gap_start++;
+ gb->gap_size--;
+ if (gb->gap_size == 0) gb_resize(gb);
+ ENSURES(is_gap_buf(gb));
+}
+
+void gb_insert_many(gapbuf_t gb, char* s) { // O(len(s)) amt
+ REQUIRES(is_gap_buf(gb));
+ for (size_t i = 0; i < strlen(s); i++) {
+ gb_insert(gb, s[i]);
+ gb_print(gb);
+ }
+ ENSURES(is_gap_buf(gb));
+}
+
+void gb_del(gapbuf_t gb) { // O(1)
+ REQUIRES(is_gap_buf(gb));
+ REQUIRES(gb_gap_in_bounds(gb, gb->gap_start - 1));
+ gb->gap_start--;
+ gb->gap_size++;
+ ENSURES(is_gap_buf(gb));
+}
+
+void gb_move(gapbuf_t gb, ptrdiff_t off) { // O(off)
+ REQUIRES(off != 0);
+ REQUIRES(gb_gap_in_bounds(gb, gb->gap_start + off));
+ gb->gap_start += off;
+ size_t to_move = abs(off);
+ if (off < 0) {
+ memcpy(gb_end(gb), gb_start(gb), to_move);
+ } else {
+ memcpy(gb_start(gb)-off,
+ gb_start(gb)+gb->gap_size-off,
+ to_move);
+ }
+ ENSURES(is_gap_buf(gb));
+}
+
+
+int main() {
+ printf("INIT\n");
+ gapbuf_t gb = gb_new(8);
+ gb_print(gb);
+ printf("\nINSERT 'int main();'\n");
+ gb_insert_many(gb, "int main();");
+ printf("\nMOVE -3\n");
+ gb_move(gb, -3);
+ gb_print(gb);
+ printf("\nINSERT '/* questionable comment */'\n");
+ gb_insert_many(gb, "/* questionable comment */");
+ printf("\nMOVE +3\n");
+ gb_move(gb, 3);
+ gb_print(gb);
+ printf("\nDELETE\n");
+ gb_del(gb);
+ gb_print(gb);
+ printf("\nINSERT ';'\n");
+ gb_insert(gb, ';');
+ gb_print(gb);
+ printf("\nMOVE -34\n");
+ gb_move(gb, -34);
+ gb_print(gb);
+ printf("\nDELETE 3\n");
+ gb_del(gb); gb_del(gb); gb_del(gb);
+ gb_print(gb);
+ printf("\nINSERT 'bool'\n");
+ gb_insert_many(gb, "bool");
+ printf("\nMOVE +34\n");
+ gb_move(gb, 34);
+ gb_print(gb);
+}
diff --git a/prob.lisp b/prob.lisp
@@ -0,0 +1,169 @@
+;; Editor's note: Helper script written for a Nature of Reason (80-150) probability assignment.
+;; An underrated quality of s-expressions is that you get to have simple rational literals...
+
+(load "~/quicklisp/setup.lisp")
+
+(defmacro defalias (to fn) `(setf (fdefinition ',to) #',fn))
+(defalias filter remove-if-not)
+(defmacro fn (&body body) `(lambda () ,@body))
+(defmacro fnx (&body body) `(lambda (x) ,@body))
+
+(defun fact (x &optional (acc 1))
+ (if (zerop x) acc
+ (fact (- x 1) (* acc x))))
+
+(defun choose (n k)
+ (/ (fact n) (* (fact k) (fact (- n k)))))
+
+(defun generate (f n)
+ (loop for i from 0 to (- n 1) collect (funcall f)))
+
+(defun generate-cond (f p n &optional (acc nil))
+ (if (eq (length acc) n) acc
+ (let ((res (funcall f)))
+ (generate-cond f p n (if (funcall p res) (cons res acc) acc)))))
+
+(defun exp/prob (sample pred &optional (samples 10000))
+ "Estimates probability of P being true by repeatedly sampling space via SAMPLE."
+ (/ (length (filter pred (generate sample samples)))
+ (float samples)))
+
+(defun exp/cond-prob (sample cond pred &optional (samples 10000))
+ "Estimates probability of PRED being true given COND by repeatedly sampling space via SAMPLE."
+ (let ((cands (generate-cond sample cond samples)))
+ (/ (length (filter pred cands))
+ (float (length cands)))))
+
+(defun exp/compare (exp theory)
+ (abs (- exp theory)))
+
+(defun thm/mutex-or (&rest args) (reduce '+ args))
+(defun thm/or (a b both) (- (+ a b) both))
+(defun thm/indp-and (a b) (* a b))
+(defun thm/indp-trials (trials successes psuccess)
+ (abs (* (choose trials successes)
+ (expt psuccess successes)
+ (expt (1- psuccess) (- trials successes)))))
+(defun thm/cond (a given both) (/ both given))
+(defun thm/bayes (a given flipped) (/ (* flipped a) given))
+
+(defun thm/not (a) (- 1 a))
+
+(defun is-prime (n &optional (d (- n 1)))
+ (or (= d 1)
+ (and (/= (rem n d) 0)
+ (is-prime n (- d 1)))))
+
+(defun flip-coin (&key (times 1) (heads-bias nil))
+ (let ((f (if heads-bias (lambda () (if (< (random 1.0) heads-bias) 'heads 'tails))
+ (lambda () (nth (random 2) '(heads tails))))))
+ (if (eq times 1) (funcall f) (generate f times))))
+
+;; PROBLEM 1
+;; a)
+(exp/compare
+ (exp/prob (fn (1+ (random 6))) (fnx (or (oddp x) (is-prime x))) 1000000)
+ (thm/or 3/6 3/6 2/6))
+
+;; b)
+
+(exp/compare
+ (exp/cond-prob
+ (lambda () (flip-coin :times 11))
+ (lambda (flips) (every (lambda (x) (eq x 'tails)) (subseq flips 0 9)))
+ (lambda (flips) (eq (car (last flips)) 'heads)) 1000)
+ (thm/cond 1/2 (thm/indp-trials 10 10 1/2) (thm/indp-trials 11 11 1/2)))
+
+;; c)
+
+(exp/compare
+ (exp/prob
+ (fn (flip-coin :heads-bias 2/3 :times 2))
+ (fnx (equal x '(heads heads))))
+ (thm/indp-trials 2 2 2/3))
+
+(exp/compare
+ (exp/prob
+ (fn (flip-coin :heads-bias 2/3 :times 2))
+ (fnx (equal x '(heads tails))))
+ (thm/indp-and 2/3 1/3))
+
+;; d)
+(exp/compare
+ (exp/prob
+ (fn (flip-coin :times 3))
+ (fnx (not (equal x '(heads heads heads)))))
+ (thm/not (thm/indp-trials 3 3 1/2)))
+
+(exp/compare
+ (exp/prob
+ (fn (flip-coin :times 3))
+ (fnx (some (fnx (eq x 'heads)) x)))
+ (thm/mutex-or (thm/indp-trials 3 1 1/2)
+ (thm/indp-trials 3 2 1/2)
+ (thm/indp-trials 3 3 1/2)))
+
+
+(defun exp/frac (p)
+ (< (random 1.0) p))
+
+;; Shitty imperative code.
+(defun exp/weighted-choose (choices)
+ (let ((x (random 1.0)) (cmp 0) (out nil))
+ (dolist (pair choices)
+ (incf cmp (cadr pair))
+ (if (< x cmp)
+ (return-from exp/weighted-choose (car pair))))))
+
+;; problem 2
+;;
+;; P(A|S) = 3/5
+;; P(S) = 4/5
+;; P(A|~S) = 1/9
+;; P(A)?
+;; P(A) = P(A|S)P(S) + P(A|~S)P(~S) by Bayes'
+(exp/compare
+ (exp/prob (fn (if (exp/frac 4/5) (exp/frac 3/5) (exp/frac 1/9)))
+ (fnx (eq x t)) 1000000)
+ (+ (* 3/5 4/5) (* 1/9 1/5)))
+
+;; 2b
+;;
+;; P(B) = 0.2
+;; P(L|B) = 0.07
+;; P(L) = P(L|W)P(W) + P(L|B)P(B) + P(L|C)P(C) = 0.1*0.5 + 0.03*0.3 + 0.07*0.2 = 0.2
+;; P(B|L) = (P(L|B)P(B))/P(L) by Bayes'
+
+(exp/compare
+ (exp/cond-prob
+ (fn (let ((transit (exp/weighted-choose '((walk 0.5) (car 0.3) (bus 0.2)))))
+ (list transit (case transit
+ (walk (exp/frac 0.1))
+ (car (exp/frac 0.03))
+ (bus (exp/frac 0.07))))))
+ (fnx (eq (cadr x) t))
+ (fnx (eq (car x) 'bus)) 10000)
+ (thm/bayes 2/10
+ (thm/mutex-or (thm/indp-and 1/10 5/10)
+ (thm/indp-and 3/100 3/10)
+ (thm/indp-and 7/100 2/10))
+ 7/100))
+
+;; problem 3
+
+;; example: numbers from 0 to 50 (exclusive)
+;; event B: x is even
+;; event A: x is divisible by 10
+
+(exp/prob
+ (fn (random 50))
+ (fnx (or (not (zerop (mod x 2)))
+ (zerop (mod x 10)))))
+
+(remove-if-not (fnx (zerop (mod x 10))) (loop for i from 0 to 49 collect i))
+
+(exp/cond-prob
+ (fn (random 50))
+ (fnx (zerop (mod x 2)))
+ (fnx (zerop (mod x 10))))
+
diff --git a/regex.lisp b/regex.lisp
@@ -0,0 +1,100 @@
+;; Editor's note: Experiments with Coalton and the paper "A Play on Regular Expressions"
+;; by Sebastian Fischer, Frank Huch, and Thomas Wilke.
+
+(ql:quickload :coalton)
+
+(defpackage #:regex-play
+ (:use
+ #:coalton
+ #:coalton-prelude)
+ (:local-nicknames
+ (#:str #:coalton-library/string)
+ (#:list #:coalton-library/list)
+ (#:iter #:coalton-library/iterator)))
+
+(in-package #:regex-play)
+
+(coalton-toplevel
+ (declare explode ((String -> (List Char))))
+ (define (explode s) (iter:collect! (str:chars s)))
+
+ (declare splits ((List :a) -> (List (Tuple (List :a) (List :a)))))
+ (define (splits l)
+ (match l
+ ((Nil) (singleton (tuple nil nil)))
+ ((Cons c cs)
+ (cons (tuple nil (cons c cs))
+ (map (fn ((Tuple s1 s2)) (tuple (cons c s1) s2)) (splits cs))))))
+
+ (declare parts ((List :a) -> (List (List (List :a)))))
+ (define (parts l)
+ (match l
+ ((Nil) (singleton nil))
+ ((Cons c nil) (singleton (singleton (singleton c))))
+ ((Cons c cs)
+ (let ((f (fn (part) (match part ((Nil) nil)
+ ((Cons p ps) (make-list (cons (cons c p) ps) (cons (singleton c) part)))))))
+ (list:concat (map f (parts cs)))))))
+
+ (define-class (Semiring :s)
+ (zero :s)
+ (one :s)
+ (plus (:s -> :s -> :s))
+ (times (:s -> :s -> :s)))
+
+ (declare rsum ((Semiring :s) => ((List :s) -> :s)))
+ (define (rsum l) (foldr plus zero l))
+
+ (declare rprod ((Semiring :s) => ((List :s) -> :s)))
+ (define (rprod l) (foldr times one l))
+
+ (define-type Reg
+ (REps)
+ (RSym Char)
+ (RAlt Reg Reg)
+ (RSeq Reg Reg)
+ (RRep Reg))
+
+ (define-type (WReg :c :s)
+ (WEps)
+ (WSym (:c -> :s))
+ (WAlt (WReg :c :s) (WReg :c :s))
+ (WSeq (WReg :c :s) (WReg :c :s))
+ (WRep (WReg :c :s)))
+
+ (declare sym ((Semiring :s) => (Char -> (WReg Char :s))))
+ (define (sym c) (WSym (fn (x) (if (== x c) one zero))))
+
+ (declare weighted ((Semiring :s) => (Reg -> (WReg Char :s))))
+ (define (weighted r)
+ (match r
+ ((REps) WEps)
+ ((RSym c) (sym c))
+ ((RAlt p q) (WAlt (weighted p) (weighted q)))
+ ((RSeq p q) (WSeq (weighted p) (weighted q)))
+ ((RRep r) (WRep (weighted r)))))
+
+ (declare accept ((Semiring :s) => ((WReg :c :s) -> (List :c) -> :s)))
+ (define (accept r u)
+ (match r
+ ((WEps) (if (== (length u) 0) one zero))
+ ((WSym f) (match u ((Cons c nil) (f c)) (_ zero)))
+ ((WAlt p q) (plus (accept p u) (accept q u)))
+ ((WSeq p q) (rsum (map (fn ((Tuple u1 u2)) (times (accept p u1) (accept q u2))) (splits u))))
+ ((WRep r) (rsum (map (compose rprod (map (accept r))) (parts u))))))
+
+ (define-instance (Semiring Boolean)
+ (define zero False)
+ (define one True)
+ (define (plus x y) (or x y))
+ (define (times x y) (and x y)))
+
+ (define-instance (Semiring Integer)
+ (define zero 0)
+ (define one 1)
+ (define (plus x y) (+ x y))
+ (define (times x y) (* x y))))
+
+(coalton
+ (let ((as (RAlt (RSym #\a) (RRep (RSym #\a)))))
+ (the Integer (accept (weighted as) (explode "aaa")))))
diff --git a/ropes.sml b/ropes.sml
@@ -0,0 +1,71 @@
+(* Editor's note: transmuting an assignment from one CMU class to another...
+ * Sometimes things are easier when the language isn't fighting you :)
+ * Comments are lightly edited. *)
+
+datatype rope = Leaf of string | Cat of rope ref * rope ref
+
+structure Rope =
+struct
+fun size (ref (Leaf s)) = String.size s
+ | size (ref (Cat(l, r))) = size l + size r
+
+fun charat (ref (Leaf s)) i = String.sub (s, i)
+ | charat (ref (Cat(l, r))) i = let
+ val leftSize = size l
+ in
+ if leftSize > i then charat l i else charat r (i - leftSize)
+ end
+
+fun toString (ref (Leaf s)) = s
+ | toString (ref (Cat(l, r))) = (toString l) ^ (toString r)
+
+fun join (L, R) = ref (Cat(L, R))
+
+(* Nasty casework: the use of refcells and my lack of knowledge of their semantics also
+ * means I had to punt the casework to a case expr so that I could return the original
+ * reference if needed. *)
+fun sub R lo hi =
+ if (lo = 0 andalso hi = (size R)) then R else
+ (case R of
+ (ref (Leaf s)) => ref (Leaf(String.substring(s, lo, hi)))
+ | (ref (Cat(l, r))) => let
+ val leftSize = size l
+ in
+ (case (hi < size l, size l <= lo) of
+ (* is the substring all on the left? then recur on left *)
+ (true, _) => sub l lo hi
+ (* vice versa *)
+ | (_, true) => sub r 0 (hi - size l)
+ (* otherwise take what we want from either side *)
+ | _ => join (sub l lo leftSize, sub r 0 (hi-leftSize)))
+ end)
+
+(* Takes a list of ropes and modifies them to reuse subtrees from earlier elements in
+ * the list (thus 'reducing' the overall size of the collection of ropes). *)
+fun reduce ropes = let
+ (* Gross and imperative code both in the hashtable usage and in the overuse of let
+ * blocks to do things in sequence. In my defense it was 2AM when I had this idea. *)
+ val ropeEqual = fn (R1, R2) => (toString R1) = (toString R2)
+ val ropeHash = fn R => HashString.hashString (toString R)
+ exception NotFound
+ val H = HashTable.mkTable (ropeHash, ropeEqual) (100, NotFound)
+
+ fun reduceHelp H R =
+ HashTable.lookup H R
+ handle NotFound =>
+ let val () = (HashTable.insert H (R,R)) in
+ (case R of (ref (Leaf s)) => R
+ | (ref (Cat (l, r))) => join (reduceHelp H l, reduceHelp H r))
+ end
+ in
+ map (fn x => let val () = x := !(reduceHelp H x) in x end) ropes
+end
+end
+
+val r1 = ref (Cat (ref (Leaf "a"), ref (Leaf "br")))
+val r2 = ref (Cat (ref (Leaf "abr"), ref (Leaf "a")))
+val r3 = ref (Cat (ref (Leaf "a"), ref (Cat (ref (Leaf "br"), ref (Leaf "a")))))
+
+(* seems to work and like... it typechecks™
+ * (but seriously, not rigorously tested) *)
+val out = Rope.reduce [r1, r2, r3]
diff --git a/stack.lisp b/stack.lisp
@@ -0,0 +1,166 @@
+;; Editor's note: this is a "letter" (file?) I sent to my sister in response to
+;; her asking me why her Emacs Lisp function was hitting a recursion limit.
+;; This was only a couple days after I had finished 15-150's CPS lab so the
+;; timing was great for me to get nerdsniped into talking about CPS and stacks.
+
+;;
+;; As you just discovered, some recursive functions are not "stack-safe"
+;;
+;; I've mentioned to you before that when you call a function, a "stack frame"
+;; containing the memory needed for its local variables and such is pushed to
+;; a processes' stack and then popped when the function returns (this way the
+;; preserves the state of the function that calls another function)
+;;
+;; The consequence of this is that the deeper a recursion goes, the more memory
+;; is (traditionally) needed! This sorta blows since there's plenty of regular
+;; recursive algorithms that we would like to work.
+;;
+;; One observation we can make is that we don't need to preserve the state of
+;; a parent function if the recursive call is the _last_ thing we do (there's
+;; nothing to come back to!). This is called "tail recursion" and we can perform
+;; "tail call optimization" here by replacing the current stack frame with the
+;; new one when we recurse instead of pushing a new stack frame (since we don't
+;; need to come back to the old function!)
+;;
+;; Many languages sadly do not do this optimization (e.g. only some lisps like
+;; SBCL do it). Let's see an example with a factorial function.
+
+(defun bad-factorial (x)
+ (if (zerop x) 1
+ (* x (bad-factorial (- x 1)))))
+
+;; n * fact (n-1)
+;; ^ problematic because we need to do something with the result of the recursion
+
+(bad-factorial 500004)
+
+;; Calling this will murder SBCL!
+;; CL-USER> (bad-factorial 500004)
+;; Error: Control stack exhausted (no more space for function call frames).
+;;
+;; Anyways this is slow because it's not a tail call: we do multiplication
+;; after the recursion and so we need to preserve the previous stack frames.
+;;
+;; One way of fixing this would be to add an accumulator argument like so:
+
+(defun tail-factorial (x &optional (acc 1))
+ (if (zerop x) acc
+ (tail-factorial (- x 1) (* acc x))))
+
+
+;; This won't murder SBCL because it can reuse stack frames!
+(tail-factorial 50004)
+
+;; It isn't always easy to write tail recursive functions though. Let's think
+;; about a slightly harder problem: a tail recursive is-even function! As usual
+;; we'll start with a bad implementation that will murder your stack:
+
+(defun bad-is-even (x)
+ (case x
+ (0 t)
+ (1 nil)
+ (otherwise (not (bad-is-even (- x 1))))))
+
+;; Except we can't exactly add a nice accumulator argument (at least I don't
+;; think so) since without modulo (cheating here) we can't work backwards
+;; (we could earlier because multiplication is commutative) and our computation
+;; must be done when coming back out of all the recursions. This is explained
+;; a little weirdly but try and think through on your own why you can't use the
+;; same strategy as before here.
+;;
+;; There are some clever tricks we can do though! The first is being clever about
+;; some "mutual recursion" in which we define two recursive functions even? and
+;; odd? that call each other. Sidenote: these are still tail calls because the
+;; recursion is the last thing that happens!
+
+(defun odd? (x)
+ (if (= x 0) nil (even? (- x 1))))
+
+(defun even? (x)
+ (if (= x 0) t (odd? (- x 1))))
+
+;; By using two functions we've nicely dodged our earlier problems. This is not
+;; a generally applicable solution though, and by now you might despair that most
+;; functions are not expressible as a tail recursive function. Yet this is not the
+;; case! Observe the glory of Continuation Passing Style (what I was working on in
+;; my functional programming pset all of last week).
+;;
+;; Some background: a continuation passing style function is a tail recursive function
+;; that additionally takes a lambda function of "what to do after this" (and calls it
+;; as a tail call. You can start to build up some sneakiness here by calling more CPS
+;; functions and build up arbitrary logic. Let's see a simple example with a factorial
+;; function again:
+
+(defun cps-fact (x k) ;; k is "what to do next" - we call k with our result when done
+ (if (zerop x) (funcall k 0)
+ ;; Here we call ourselves again but change the continuation: now what we do with
+ ;; the result of this recursive call is multiply it by x and then pass it to k.
+ (cps-fact (- x 1) (lambda (y) (funcall k (* x y))))))
+
+;; It'll help to see what this evaluates to for an example input. I use => to indicate
+;; "evaluates to" in the following trace (also write-to-string is basically just str()
+;; from Python but in Lisp.
+;;
+;; (cps-fact 3 write-to-string)
+;; => (cps-fact 2 (lambda (y) (funcall write-to-string (* 3 y))))
+;; => (cps-fact 1 (lambda (z) (funcall (lambda (y) (funcall write-to-string (* 3 y))) (* 2 z))))
+;; => (funcall (lambda (z) (funcall (lambda (y) (funcall write-to-string (* 3 y))) (* 2 z))) 1)
+;; => (funcall (lambda (y) (funcall write-to-string (* 3 y))) (* 2 1))
+;; => (funcall (lambda (y) (funcall write-to-string (* 3 y))) 2)
+;; => (funcall write-to-string (* 3 2))
+;; => (write-to-string 6)
+;; => "6"
+;;
+;; Along the way we used nothing but tail calls! Hopefully after some more inspection
+;; you can sort of see how we've basically punted all state to these growing lambda
+;; functions that encode what to do next.
+;;
+;; We can also do this for our is-even function! Here's how it would work:
+
+(defun cps-even (x k)
+ (case x
+ (0 (funcall k t))
+ (1 (funcall k nil))
+ (otherwise (cps-even (- x 1) (lambda (y) (funcall k (not y)))))))
+
+;; Try writing a trace out for yourself. Also we can call the function on big inputs!
+
+(cps-even 100003 'write-to-string)
+(cps-even 100006 'write-to-string)
+
+;; The cooler thing about continuation passing style is that it can express *anything*!
+;; Maybe I'll send you some more complicated examples like what I did in my homework to
+;; show this, but CPS is a whole style of programming (I wrote a SAT solver (google it)
+;; in SML exclusively doing things this way!).
+;;
+;; Anyways, yeah this has been your primer on avoiding stack overflows in functional
+;; languages. We can also be evil and do this kind of stuff imperatively. We can use
+;; setf to update variables from let clauses in our factorial function.
+
+(defun evil-fact (x)
+ (let ((out 1))
+ (dotimes (_ x)
+ (setf out (* x out)
+ x (- x 1)))
+ out))
+
+;; Never do this. It is evil. I mean sometimes it is motivated: Lisp is actually a
+;; multi-paradigm language and so if functional ever starts being a chore you can
+;; always just not bother (don't though, that's cringe).
+;;
+;; Alternatively we can channel the dark arts of the loop macro:
+
+(defun loop-fact (x)
+ (loop with out = 1
+ for i from 2 to x
+ do (setf out (* out i))
+ finally (return out)))
+
+;; Or if we like loop (it's actually the only clean range() equivalent) and hate setf
+;; (as one rightfully should) we could do a more functional implementation with reduce:
+
+(defun other-loop-fact (x)
+ (reduce '* (loop for i from 1 to x collect i)))
+
+;; Okay bye now it's 2 AM.
+
diff --git a/turing.sml b/turing.sml
@@ -0,0 +1,163 @@
+(* Editor's note: A random script I wrote for a Nature of Reason (80-150) assignment.
+ * The below introductory comment is taken from my submission:
+ *
+ * I was procrastinating a bit last week and so I wrote up a little Standard ML program to
+ * simulate a Turing Machine!
+ *
+ * The bulk of the work is in representing the infinite tape of the Turing machine: I
+ * considered having some wonky double-ended stream at first but I ended up just using a
+ * function of type int -> bool to represent the state of the tape (thus to set index j to
+ * true, you would redefine the existing function f to be fn i => i = j orelse f i). This
+ * is pretty wasteful in terms of memory usage since it means that a Turing program that
+ * just flips one cell forever would use increasing amounts of memory, but explicitly
+ * tracking which cells have been flipped seem like a bunch of work.
+ *
+ * The actual Turing program evaluator is super simple: it just fetches the rules for the
+ * current state from the program, applies them to the tape, and recurses (with the base
+ * case being state 0).
+ *
+ * I almost wrote a parser for this too (did you know SMLNJ ships with a parser combinator
+ * library?!), but some of the validation logic was icky and so I ran out of energy.
+ * Final tidbit: the tape has to track some other metadata (current position, bounds of 1s
+ * to read) and so I actually use a wackier feature of SML: flex records (look at the type
+ * definition for tape! or try typing something like {x=2, y="whee"} into your SML
+ * interpreter!). They’re basically anonymous named tuples. Kinda cool feature which I
+ * haven’t seen in any other language (to be fair they’re a bit limited: often SML will
+ * complain if you try to write polymorphic functions that access fields of arbitrary flex
+ * records). *)
+
+datatype direction = Left | Right
+type rule = (int * bool * direction)
+type instr = (rule * rule)
+
+signature TAPE = sig
+ type tape
+ val inpNum : int -> tape
+ val inpPair : int*int -> tape
+ val outNum : tape -> int
+ val toList : tape -> bool list
+ val get : tape -> bool
+ val set : tape -> bool -> tape
+ val move : tape -> direction -> tape
+end
+
+structure Tape :> TAPE = struct
+type tape = {bounds: (int * int), loc: int, f: int -> bool}
+fun inpNum x = {bounds=(0, x), loc=0, f=fn i => i >= 0 andalso i <= x}
+
+fun inpPair (x,y) =
+ {bounds=(0, x+y+3), loc=0, f=(fn i => (i >= 0 andalso i <= x) orelse
+ (i > x+1 andalso i <= x+2+y))}
+
+fun toList (t : tape) =
+ let val (min,max) = #bounds t
+ in List.tabulate (max-min, fn i => (#f t) (min+i)) end
+
+fun outNum (t : tape) = let
+ fun count (t : tape) i sum =
+ if i > (#2 (#bounds t)) then sum
+ else count t (i+1) (sum + (if ((#f t) i) then 1 else 0))
+in
+ count t (#1 (#bounds t)) 0
+end
+
+fun get (t : tape) = (#f t) (#loc t)
+fun set (t : tape) new = let
+ val (min, max) = #bounds t
+ val min = Int.min(min, #loc t)
+ val max = Int.max(max, #loc t)
+in
+ {bounds=(min,max), loc=(#loc t),
+ f=(fn i => if i = (#loc t) then new else (#f t) i)}
+end
+fun move (t : tape) dir =
+ let val shift = (case dir of Left => ~1 | Right => 1)
+ in {bounds=(#bounds t), loc=(#loc t)+shift, f=(#f t)} end
+end
+
+fun eval t 0 _ = t
+ | eval (tape : Tape.tape) (state : int) (instrs : instr list) = let
+ val ins = List.nth (instrs, state - 1)
+ val (newstate, newval, dir) = if Tape.get tape then #2 ins else #1 ins
+in
+ eval (Tape.move (Tape.set tape newval) dir) newstate instrs
+end
+
+(* I originally had a parser for this, but it ended up being too much of a
+ * hassle (being able to leave off unreachable rules for some states and
+ * other stuff made it annoying to parse). Instead programs are represented
+ * as a list of instructions where the nth item represents the two rules
+ * for the nth state (rule being what to do for a 0 and what to do for a 1. *)
+
+val plus3 = [((2, true, Right), (1, true, Right)),
+ ((0, true, Right), (0, true, Right))]
+
+val ident = [((1, true, Right), (0, false, Right))]
+
+val three = [((2, true, Right), (2, true, Right)),
+ ((3, true, Right), (3, true, Right)),
+ ((4, true, Right), (4, true, Right)),
+ ((0, false, Right), (4, false, Right))]
+
+val add = [((1, false, Right), (2, false, Right)),
+ ((3, false, Right), (2, true, Right)),
+ ((0, false, Right), (0, false, Right))]
+
+
+val mock = [((0, false, Right), (2, true, Right)),
+ ((0, true, Right), (3, false, Left)),
+ ((0, false, Right), (0, false, Left))]
+
+(* Editor's note: The buried remnants of my attempt at a parser: *)
+
+(* structure P = ParserComb *)
+
+(* fun skipWS parser = P.skipBefore Char.isSpace parser *)
+(* (* Combines two parsers, ignoring whitespace. *) *)
+(* fun +> (a, b) = P.seq (a, skipWS(b)) *)
+(* infixr 3 +> *)
+(* (* Only keeps the right hand result. *) *)
+(* fun %> (a, b) = P.wrap(a +> b, #2) *)
+(* infixr 3 %> *)
+(* (* Only keeps the left hand result. *) *)
+(* fun @> (a, b) = P.wrap(a +> b, #1) *)
+(* infixr 3 @> *)
+
+(* (* Optionally applies a parser. On failure, parses to NONE instead of passing *)
+(* * an actual failure up and causing the overall parse to fail. *) *)
+(* fun parseOptional parser getc = P.or (P.wrap (parser, SOME), P.result NONE) getc *)
+
+(* fun parseState getc = ((P.char #"q") %> (Int.scan StringCvt.DEC)) getc *)
+(* fun parseDir getc = P.or(P.wrap(P.char #"L", fn _ => Left), *)
+(* P.wrap(P.char #"R", fn _ => Right)) getc *)
+(* fun parseVal getc = P.or'([P.wrap(P.char #"B", fn _ => false), *)
+(* P.wrap(P.char #"0", fn _ => false), *)
+(* P.wrap(P.char #"1", fn _ => true)]) getc *)
+
+(* fun parseRule getc = *)
+(* P.wrap(parseState +> P.or'([P.wrap(P.char #"1", fn _ => true), *)
+(* P.wrap(P.char #"0", fn _ => false), *)
+(* P.wrap(P.char #"B", fn _ => false)]) *)
+(* +> P.wrap(parseState +> parseVal +> parseDir, *)
+(* fn (s, (v, d)) => (s,v,d)), *)
+(* fn (s, (i, r)) => (s, i, r)) getc *)
+
+(* exception Parse *)
+(* fun strToRule str = Option.valOf (StringCvt.scanString parseRule str) *)
+(* handle Option => raise Parse *)
+
+(* fun parseRules rules = let *)
+(* val rules = map strToRule rules *)
+(* in *)
+
+(* end *)
+
+(* (* in *) *)
+
+(* (* end *) *)
+
+(* val prog = [ *)
+(* "q3 1 q2 1 R", *)
+(* "q3 0 q2 1 R", *)
+(* "q2 1 q0 1 R" *)
+(* ] *)
