Skip to content

Instantly share code, notes, and snippets.

@hiredman

hiredman/pi.clj

Created September 6, 2021 03:22
Show Gist options
  • Save hiredman/a3415450d78fa234a5dcc56fa0228e36 to your computer and use it in GitHub Desktop.
Save hiredman/a3415450d78fa234a5dcc56fa0228e36 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
pi.clj
;; (load-file "/home/kevin/src/pi.clj")
(require '[clojure.pprint :as pp]
'[clojure.java.io :as io])
(def grammar
[[:program [:process 'eof?]]
[:process [:receive]]
[:process [:send]]
[:process [:par]]
[:process [:new]]
[:process [:repeat]]
[:process [:null]]
[:process [:sum]]
[:process [\( :process \)]]
[:send [:name \! :name \. :process]]
;; support strings so hello world works
[:send [:name \! :string \. :process]]
[:receive [:name \? :name \. :process]]
[:par [:process \| :process]]
[:new [:name \. :process]]
[:sum [:process \+ :process]]
[:repeat [\! :process]]
[:null [\0]]
[:name ['name-part?]]
[:name [:name :name]]
[:string [\" :string-parts \"]]
[:string-parts [:string-parts :string-part]]
[:string-parts [:string-part]]
[:string-part ['string-part?]]
;; [:string-part [:escape-sequence]]
;; [:escape-sequence [\\ :digits]]
;; [:digits [:digits :digits]]
;; [:digits ['digit?]]
])
;; create a shift/reduce parser for the grammar
(defn reducers [G]
(for [[production body] G
i [`(~'and
(>= (count ~'stack) ~(count body))
~@(map-indexed
(fn [i thing]
`(~'= '~thing (~'first (~'first ~(list* '-> 'stack (repeat i 'rest))))))
(reverse body)))
(if (and (= production (first (first G)))
(= 'eof? (last body)))
`(~'vec (~'cons ~production (~'reverse (~'take ~(count body) ~'stack))))
`(recur
(~'cons
(~'vec (~'cons ~production (~'reverse (~'take ~(count body) ~'stack))))
(~'drop ~(count body) ~'stack))
~'i))]]
i))
(defn terminals [G]
(set
(for [[_ body] G
part body
:when (not (keyword? part))]
part)))
(defn shifters [G]
(letfn [(f [x seen]
(for [[p b :as r] G
:when (not (seen r))
:let [indices (keep-indexed
(fn [idx item]
(when (= item x)
idx))
b)]
idx (if (seq indices)
indices
[-1])
n (cond (pos? idx)
[(nth b (dec idx))]
(and (zero? idx) (not= :program p))
(f p (conj seen r))
(and (zero? idx) (= :program p))
[nil]
(neg? idx)
[])]
n))]
(for [[before seen] (distinct
(for [terminal (terminals G)
n (f terminal #{})]
[n terminal]))
i [`(~'and
~(if (symbol? seen)
`(~seen ~'c)
`(~'= ~'c ~seen))
(~'= ~before (~'first (~'first ~'stack))))
`(~'recur (~'cons ['~seen ~'c] ~'stack)
(~'. ~'in (~'read)))]]
i)))
(defn eof? [c] (= c :eof))
(defn string-part? [c] (and (char? c)
(not= c \")
(not= c \\)))
(defn name-part? [c]
(and (char? c)
(Character/isLetter c)))
(defmacro mk-parser [grammar]
`(fn [~'in]
(~'loop [~'stack ()
~'i (.read ~'in)]
(~'let [~'c (~'if (~'neg? ~'i) :eof (~'char ~'i))]
(~'cond
~@(reducers @(resolve grammar))
~@(shifters @(resolve grammar))
(~'and (~'not= ~'c :eof) (Character/isWhitespace ~'c))
(~'recur ~'stack (~'. ~'in (read)))
:else
(~'throw
(~'new ~'Exception
(~'str "unexpected " (~'pr-str ~'c) " following a " (~'pr-str (~'first (~'first ~'stack)))))))))))
(def parse (mk-parser grammar))
;; that parser feels so dirty
(defn fold
"takes a map of tags to functions and folds over a tagged tree of
values."
[fs init root]
(apply (or (get fs (nth root 0))
(throw (Exception. (str (nth root 0)))))
(partial fold fs)
init
root))
(defn normalize-ast
"Takes the parse tree returned by the parser and cleans it
up. Throws away parsed syntax we don't need, and collapses names and
strings into reasonable values instead of weird parse trees."
[ast]
(fold {:program (fn [f _ _ ast _] [:program (f nil ast) [:eof]])
:par (fn [f _ _ ast1 _ ast2] [:par (f nil ast1) (f nil ast2)])
:send (fn [f _ _ ast1 _ ast2 _ ast3]
[:send (f nil ast1) (f nil ast2) (f nil ast3)])
:name (fn
([_ _ _ ast]
(-> ast
(nth 1)
(str)))
([f _ _ ast1 ast2]
(str (f nil ast1) (f nil ast2))))
:new (fn b [f _ _ ast1 _ ast2]
[:new (f nil ast1) (f nil ast2)])
:process (fn a
([f _ _ _ ast _]
(f nil ast))
([f _ _ ast]
[:process (f nil ast)]))
:string (fn [f _ _ _ ast _]
[:string (f nil ast)])
:string-parts (fn
([f _ _ ast]
(-> ast
(nth 1)
(nth 1)
(str)))
([f _ _ ast1 ast2]
(str (f nil ast1)
(f nil ast2))))
:string-part (fn [f _ _ ast]
(str (nth ast 1)))
:null (constantly [:null])
:repeat (fn [f _ _ _ ast] [:repeat (f nil ast)])
:receive (fn [f _ _ ast1 _ ast2 _ ast3]
[:receive (f nil ast1) (f nil ast2) (f nil ast3)])}
nil
ast))
(defn p-s [s]
(parse
(java.io.InputStreamReader.
(java.io.ByteArrayInputStream.
(.getBytes s)))))
;; (p-s "c.(c!c.0|c?c.0)")
;; (p-s "PRINT!\"Hello World\".0")
(defn pi->locally-nameless
"Takes an ast De Bruijn indexes it"
([tree] (pi->locally-nameless tree {}))
([tree env]
(fold {:new (fn [f env _ name process]
[:new (f (assoc (into {} (for [[k v] env] [k (inc v)]))
name
0)
process)])
:par (fn [f env _ p1 p2] [:par (f env p1) (f env p2)])
:send (fn [f env _ n1 n2 p]
(assert (contains? env n1) n1)
(assert (contains? env n2))
[:send (get env n1) (get env n2) (f env p)])
:null (constantly [:null])
:repeat (fn [f env _ p] [:repeat (f env p)])
:receive (fn [f env _ n1 n2 p]
[:receive
(get env n1)
(f (assoc (into {} (for [[k v] env] [k (inc v)]))
n2
0)
p)])}
env
tree)))
(defn strings
"Replaces string literals in a program with refences to a string
table, returns a pair of [program string-table]"
[program string-table]
(fold {:program (fn [f string-table _ body eof] (f string-table body))
:process (fn [f string-table _ body] (f string-table body))
:new (fn [f string-table _ name program]
(let [[b st] (f string-table program)]
[[:new name b] st]))
:par (fn [f string-table _ p1 p2]
(let [[p1 string-table] (f string-table p1)
[p2 string-table] (f string-table p2)]
[[:par p1 p2] string-table]))
:send (fn [f string-table _ n1 n2 p]
(let [[p string-table] (f string-table p)]
(if (string? n2)
[[:send n1 n2 p] string-table]
(let [s (nth n2 1)]
(if (contains? string-table s)
[[:send n1 (get string-table s) p] string-table]
(let [n (str (gensym))
st (assoc string-table s n)]
[[:send n1 n p] st]))))))
:null (fn [_ string-table _]
[[:null] string-table])
:repeat (fn [f string-table _ p]
(let [[p string-table] (f string-table p)]
[[:repeat p] string-table]))
:receive (fn [f string-table _ n1 n2 p]
(let [[p string-table] (f string-table p)]
[[:receive n1 n2 p] string-table]))}
string-table
program))
(defn exec [dir & command-line]
(.start
(doto (ProcessBuilder. (into [] (map name) command-line))
(.directory (io/file dir)))))
(defn git-empty-object
"Adds an empty blob to the given git repo, returns the sha"
[repo]
(let [proc (exec repo :git :hash-object "-w" "--stdin")]
(.close (.getOutputStream proc))
(first (.split (slurp (.getInputStream proc)) "\n"))))
(defn git-tree [repo blobs]
(let [proc (exec repo :git :mktree)]
(with-open [out (io/writer (.getOutputStream proc))]
(doseq [[name sha] blobs]
(.write out (format "00644 blob %s\t%s" sha name))))
(first (.split (slurp (.getInputStream proc)) "\n"))))
(defn git-commit [repo tree parents]
(let [proc (apply exec repo :git :commit-tree tree
(for [p parents i ["-p" p]] i))]
(with-open [out (io/writer (.getOutputStream proc))]
(.write out "x"))
(first (.split (slurp (.getInputStream proc)) "\n"))))
(defn git-commit-nop [repo parents]
(let [obj (git-empty-object repo)
tree (git-tree repo {(str (java.util.UUID/randomUUID)) obj})
commit (git-commit repo tree parents)
tree (git-tree repo {})
commit (git-commit repo tree [commit])]
commit))
(defn git-merge [repo parents]
(let [obj (git-empty-object repo)
tree (git-tree repo {})
commit (git-commit repo tree parents)]
commit))
(defn git-encode-i [repo i]
(loop [i i
commit (git-commit-nop repo [])]
(if (zero? i)
commit
(recur (dec i) (git-commit-nop repo [commit])))))
(defn pi-to-git [repo pi-program]
(fold {:program (fn [f _ _ constants pi-program]
(if (seq constants)
(let [proc (exec repo :git :hash-object "-w" "--stdin")
_ (with-open [dos (java.io.DataOutputStream.
(.getOutputStream proc))]
(doseq [[s _] (sort-by (comp - val) constants)]
(.writeUTF dos s)))
text (first (.split (slurp (.getInputStream proc)) "\n"))
proc (exec repo :git :mktree)
_ (with-open [out (io/writer (.getOutputStream proc))]
(.write out (format "00644 blob %s\t%s" text "text")))]
(git-merge repo
[(git-commit repo (first (.split (slurp (.getInputStream proc)) "\n")) [])
(f nil pi-program)
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])]))
(pi-to-git repo pi-program)))
:new (fn [f _ _ pi-program]
(git-merge
repo
[(f nil pi-program)
(git-commit-nop repo [])
(git-commit-nop repo [])]))
:par (fn [f _ _ p1 p2]
(git-merge repo
[(f nil p1)
(f nil p2)
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])]))
:send (fn [f _ _ c1 c2 pi-program]
(git-merge repo
[(git-encode-i repo c1)
(git-encode-i repo c2)
(f nil pi-program)
(git-commit-nop repo [])
(git-commit-nop repo [])]))
:null (fn [f _ _]
(git-merge repo [(git-commit-nop repo [])
(git-commit-nop repo [])]))
:repeat (fn [f _ _ pi-program]
(git-merge
repo
[(f nil pi-program)
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])]))
:receive (fn [f _ _ c p]
(git-merge repo
[(git-encode-i repo c)
(f nil p)
(git-commit-nop repo [])
(git-commit-nop repo [])]))
:sum (fn [f _ _ p1 p2]
(git-merge repo
[(f nil p1)
(f nil p2)
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])
(git-commit-nop repo [])]))}
nil
pi-program))
(defn count-commits [repo commit]
(loop [commit commit
i 0]
(let [proc (exec repo :git :cat-file :commit commit)
parents (reduce
(fn [parents line]
(if (empty? line)
(reduced parents)
(if (.startsWith line "parent")
(conj parents (second (.split line " ")))
parents)))
[]
(.split (slurp (.getInputStream proc)) "\n"))]
(if (seq parents)
(recur (first parents) (inc i))
(inc i)))))
(defn inter [repo initial-commit]
(loop [{:keys [commit env guard] :as c} {:commit initial-commit
:env '(PRINT)
:guard (gensym)}
e {:run-queue ()
:run-queue-tail ()
:blocked ()}]
(cond (and (nil? c)
(seq (:run-queue e)))
(recur (first (:run-queue e))
(update-in e [:run-queue] rest))
(and (nil? c)
(not (seq (:run-queue e)))
(seq (:run-queue-tail e)))
(recur c
(-> e
(assoc :run-queue (reverse (:run-queue-tail e)))
(assoc :run-queue-tail ())))
(nil? c)
nil
:else
(let [_ (assert commit c)
proc (exec repo :git :cat-file :commit commit)
parents (reduce
(fn [parents line]
(if (empty? line)
(reduced parents)
(if (.startsWith line "parent")
(conj parents (second (.split line " ")))
parents)))
[]
(.split (slurp (.getInputStream proc)) "\n"))]
(case (count parents)
2 (recur nil e)
3 (let [channel (gensym)
env (cons channel env)]
(recur {:commit (nth parents 0) :env env :guard guard} e))
4 (let [channel-name (nth env (dec (/ (count-commits repo (nth parents 0)) 2)))]
(if (e guard)
(recur nil e)
(if-let [p (first
(shuffle
(for [p (:blocked e)
:when (= :tx (:reason p))
:when (= channel-name (:channel p))
:when (not (contains? e (:guard p)))]
p)))]
(recur (assoc p :guard (gensym))
(-> e
(update-in [:run-queue-tail] conj
{:commit (nth parents 1)
:env (cons (:value p) env)
:guard guard})
(update-in [:run-queue-tail] into
(for [rp (:blocked e)
:when (= :repeat (:reason rp))
:when (or (= (:guard p) (:guard rp))
(= guard (:guard rp)))]
(assoc rp :guard (gensym))))
(assoc guard true)
(assoc (:guard p) true)))
(recur nil
(update-in e [:blocked] conj {:commit (nth parents 1)
:reason :rx
:channel channel-name
:env env
:guard guard})))))
5 (let [channel-name (nth env (dec (/ (count-commits repo (nth parents 0)) 2)))
channel-name2 (nth env (dec (/ (count-commits repo (nth parents 1)) 2)))]
(if (= channel-name 'PRINT)
(do
(println (get e channel-name2))
(recur {:commit (nth parents 2)
:env env
:guard (gensym)}
e))
(if (e guard)
(recur nil e)
(if-let [p (first
(shuffle
(for [p (:blocked e)
:when (= :rx (:reason p))
:when (= channel-name (:channel p))
:when (not (contains? e (:guard p)))]
p)))]
(recur (-> p
(update-in [:env] cons channel-name2)
(assoc :guard (gensym)))
(-> e
(update-in [:run-queue-tail] conj
{:commit (nth parents 2)
:env env
:guard (gensym)})
(update-in [:run-queue-tail] into
(for [rp (:blocked e)
:when (= :repeat (:reason rp))
:when (or (= (:guard p) (:guard rp))
(= guard (:guard rp)))]
(assoc rp :guard (gensym))))
(assoc guard true)
(assoc (:guard p) true)))
(recur nil
(update-in e [:blocked] conj {:commit (nth parents 2)
:value channel-name2
:channel channel-name
:reason :tx
:env env
:guard guard}))))))
6 (recur {:commit (nth parents 0)
:env env
:guard guard}
(update-in e [:blocked] conj {:commit commit
:env env
:reason :repeat
:guard guard}))
7 (recur nil
(update-in e [:run-queue-tail] conj
{:commit (nth parents 0)
:env env
:guard guard}
{:commit (nth parents 1)
:env env
:guard (gensym)}))
9 (let [[constants program] parents
proc (exec repo :git :cat-file :commit constants)
[t] (filter #(.startsWith % "tree")
(.split (slurp (.getInputStream proc)) "\n"))
[_ tree-sha] (.split t " ")
proc (exec repo :git :ls-tree tree-sha)
[blob-sha] (.split (nth (.split (slurp (.getInputStream proc)) " ") 2) "\t")
proc (exec repo :git :cat-file :blob blob-sha)
[env e] (with-open [das (-> (.getInputStream proc)
(java.io.DataInputStream.))]
(loop [env env
heap e]
(let [s (try (.readUTF das) (catch Throwable t))]
(if s
(let [p (gensym)]
(recur (cons p env)
(assoc heap p s)))
(do
(assert (map? heap) (type heap))
[env heap])))))]
(recur {:commit program
:env env
:guard guard}
e)))))))
(defn repl [repo]
(println "Input program:")
(let [o (java.io.ByteArrayOutputStream.)
_ (loop []
(let [line (read-line)]
(when-not (or (= line ".")
(nil? line))
(.write o (.getBytes line "utf-8"))
(.write o (int \newline))
(recur))))
ast (normalize-ast
(parse
(java.io.ByteArrayInputStream.
(.toByteArray o))))
[program constants] (strings ast {})
number-constants (reduce
(fn [env [_ v]]
(assoc env v (count env)))
{}
(sort-by key constants))
program [:program
(into {}
(map (fn [[k v]] [k (get number-constants v)]))
constants)
(pi->locally-nameless
program
(assoc number-constants "PRINT" (count number-constants)))]
_ (println "Tree:")
_ (pp/pprint program)
sha (pi-to-git repo program)
;; proc (.start
;; (doto (ProcessBuilder. ["git" "log" "--graph" sha])
;; (.directory (io/file repo))))
]
(println "Git commit in" repo ":")
(println sha)
;;(io/copy (.getInputStream proc) *out*)
(println "Running program:")
(inter repo sha)
(println)
(recur repo)))
;; % mkdir /tmp/x
;; % cd /tmp/x
;; % git init
;; git init
;; hint: Using 'master' as the name for the initial branch. This default branch name
;; hint: is subject to change. To configure the initial branch name to use in all
;; hint: of your new repositories, which will suppress this warning, call:
;; hint:
;; hint: git config --global init.defaultBranch <name>
;; hint:
;; hint: Names commonly chosen instead of 'master' are 'main', 'trunk' and
;; hint: 'development'. The just-created branch can be renamed via this command:
;; hint:
;; hint: git branch -m <name>
;; Initialized empty Git repository in /tmp/x/.git/
;; % cd
;; % clj -M -i src/pi.clj -r
;; rlwrap: warning: Your terminal 'dumb' is not fully functional, expect some problems.
;; warnings can be silenced by the --no-warnings (-n) option
;; Clojure 1.10.2
;; user=> (repl "/tmp/x")
;; Input program:
;;
;; PRINT!"Hello World".c.(c!c.0|c?c.0)
;; Tree:
;; [:program
;; {"Hello World" 0}
;; [:send 1 0 [:new [:par [:send 0 0 [:null]] [:receive 0 [:null]]]]]]
;; Git commit in /tmp/x :
;; 2c60cadb6c5239587e0fd470edc32699ab3be90b
;; Running program:
;; Hello World
;;
;; Input program:
;; C-c C-c
;; zsh: exit 130 clj -M -i src/pi.clj -r
;; % cd /tmp/x
;; % git --no-pager log --graph --oneline --decorate 2c60cadb6c5239587e0fd470edc32699ab3be90b
;; *-------------. 2c60cad x
;; |\ \ \ \ \ \ \ \
;; | | | | | | | | * d072c8f x
;; | | | | | | | | * 68c53df x
;; | | | | | | | * 66eab1f x
;; | | | | | | | * a747be3 x
;; | | | | | | * e6730e2 x
;; | | | | | | * f850115 x
;; | | | | | * 9a79dbc x
;; | | | | | * c408607 x
;; | | | | * 0d76ba6 x
;; | | | | * ef90fd0 x
;; | | | * e94e85d x
;; | | | * d742c71 x
;; | | * 3ae607e x
;; | | * ace5daa x
;; | *-----. 5642fbd x
;; | |\ \ \ \
;; | | | | | * e968e28 x
;; | | | | | * 773a310 x
;; | | | | * 11f9390 x
;; | | | | * 8e439e3 x
;; | | | *-. 8b17fcf x
;; | | | |\ \
;; | | | | | * 5bc425d x
;; | | | | | * 93790a3 x
;; | | | | * 6e5536b x
;; | | | | * 59a5de9 x
;; | | | *---------. b018948 x
;; | | | |\ \ \ \ \ \
;; | | | | | | | | | * dc69790 x
;; | | | | | | | | | * 2cedf31 x
;; | | | | | | | | * 62f537b x
;; | | | | | | | | * 4819e2a x
;; | | | | | | | * 9b6f738 x
;; | | | | | | | * 71608e3 x
;; | | | | | | * 7f236e5 x
;; | | | | | | * 5feae41 x
;; | | | | | * 7104758 x
;; | | | | | * a1fd525 x
;; | | | | *---. 50ca5cb x
;; | | | | |\ \ \
;; | | | | | | | * 5cba2cf x
;; | | | | | | | * ceb1c33 x
;; | | | | | | * cd52c08 x
;; | | | | | | * c260250 x
;; | | | | | * deed7ea x
;; | | | | | |\
;; | | | | | | * dfb82e9 x
;; | | | | | | * 91252d2 x
;; | | | | | * f94533a x
;; | | | | | * ef83ba1 x
;; | | | | * 2255e7a x
;; | | | | * e95b08f x
;; | | | *-----. d7578eb x
;; | | | |\ \ \ \
;; | | | | | | | * 41fb228 x
;; | | | | | | | * 833bfbc x
;; | | | | | | * 560d8e5 x
;; | | | | | | * 3df661e x
;; | | | | | * 68997d7 x
;; | | | | | |\
;; | | | | | | * 251e04e x
;; | | | | | | * 26e761d x
;; | | | | | * 4bfc5c5 x
;; | | | | | * d9d880a x
;; | | | | * 7780588 x
;; | | | | * 616588a x
;; | | | * 1f42102 x
;; | | | * a827306 x
;; | | * 37fdfb9 x
;; | | * b34e98e x
;; | * 34191af x
;; | * 1b425cd x
;; | * f4f72c9 x
;; | * 1e6121f x
;; * f0b4da7 x
;; %
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment