sdfsdfs

src/cljs/emptyhead/idea/crud.cljs

@@ -3,7 +3,9 @@
   The 'R' in 'CRUD' is implemented by [[emptyhead.idea.protocol/value]]."
   (:require [emptyhead.idea.state :refer [state]]
             [emptyhead.idea.property :as prop]
-            [emptyhead.idea.protocol :as prtc]))
+            [emptyhead.idea.protocol :as prtc]
+            [emptyhead.idea.memtag :as memtag]
+            [clojure.set :as set]))
 
 (defn- register-idea!
   "Helper function to scaffold an 'empty' idea."
@@ -48,11 +50,14 @@
   "Instantiate up to `count` new ideas, optionally prefixing reference symbol with `prefix`.
   Additionally allows you to immediately attach `properties` and `data`.
   Returns a single idea or a list of ideas depending on whether `count` was given."
-  [& {:keys [prefix count properties data]
+  [& {:keys [prefix count properties data shadowing]
-      :or {count 1 prefix "idea" properties []}}]
+      :or {count 1 prefix "idea" properties [] shadowing []}}]
   (let [fun #(register-idea! (gensym (str prefix "$")))
-        ideas (take count (repeatedly fun))]
+        ideas (take count (repeatedly fun))
+        shadowing (apply set/union (map prop/with-property shadowing))]
+    (run! forget-idea! shadowing)
     (run! #(apply prop/register-property! % properties) ideas)
+    (run! #(prop/register-property! % (memtag/uid-of %)) ideas)
     (when data (run! #(extend-idea! % data) ideas))
     (if (= count 1)
       (first ideas)

src/cljs/emptyhead/idea/memtag.cljs

@@ -0,0 +1,12 @@
+(ns emptyhead.idea.memtag
+  (:require [emptyhead.idea.property :as prop]
+            [emptyhead.idea.protocol :as prtc]))
+
+(defn add-group! [idea & group]
+  (let [group (or group
+                  [:emptyhead :memtag :group (keyword (gensym "memtag#group$"))])]
+    (prop/register-property! idea group)
+    group))
+
+(defn uid-of [idea]
+  [:emptyhead :memtag :uid (prtc/ref-fn keyword idea)])

src/cljs/emptyhead/idea/protocol.cljs

@@ -9,8 +9,10 @@
   (let [ref (get-in val [:_meta :_reference])]
     (cond
       (get-in val [:_meta :_stale-reference])
-      (log/error (str "Attempt to find stale reference `" ref "` -- this is a copy.")
+      (do
-                 {:value val :type :stale-reference})
+        (println "fucky wucky " val)
+        (log/error (str "Attempt to find stale reference `" ref "` -- this is a copy.")
+                   {:value val :type :stale-reference}))
 
       (not (symbol? ref))
       (log/error (str "Attempt to find invalid reference `" ref "` --  invalid idea?")
@@ -42,14 +44,15 @@
   [idea]
   (assoc-in (value idea) [:_meta :_stale-reference] true))
 
-(defn- non-copy [idea] (assoc-in (value idea) [:_meta :_stale-reference] false))
+(defn non-copy [idea] (assoc-in (value idea) [:_meta :_stale-reference] false))
 
 (defn uncopy!
   "Takes a copied idea and 'uncopies' it, making its reference active again
   and updating what is in the game state."
   [copy-obj]
   (let [idea (non-copy copy-obj)]
-    (swap! state assoc (to-reference idea) idea)))
+    (swap! state assoc (reference idea) idea)
+    (reference idea)))
 
 (defn force-reference
   "Get the (now stale!) reference of a copied idea."

src/cljs/emptyhead/lib/compose.cljs

@@ -0,0 +1,15 @@
+(ns emptyhead.lib.compose
+  (:require [emptyhead.idea.memtag :as memtag]
+            [emptyhead.thought.extend :as extend]
+            [emptyhead.thought.crud :as thought]
+            [emptyhead.thought.define :as def]))
+
+;; Append `(:data thought)` as execution child of `parent`.
+(def/define! [:emptyhead :compose :append]
+  (fn [thought parent]
+    (let [op (:data thought)
+          stage [:emptyhead :compose :append (memtag/uid-of parent) (memtag/uid-of op)]
+          op (extend/register-extension! op stage)
+          parent (thought/add-ext-stage! parent stage)]
+
+      [parent nil])))

src/cljs/emptyhead/lib/context.cljs

@@ -0,0 +1,18 @@
+(ns emptyhead.lib.context
+  (:require [emptyhead.idea.memtag :as memtag]
+            [emptyhead.thought.define :as def]
+            [emptyhead.thought.crud :as thought]
+            [emptyhead.idea.protocol :as prtc]))
+
+(def/define! [:emptyhead :core :context]
+  (fn [thought parent]
+    [parent nil])
+  :constr-fn
+  (fn [thought parent]
+    {:data {:parent (memtag/uid-of parent)}}))
+
+(defn new-context [& name]
+  (let [ctx (thought/register-thought! [:emptyhead :core :context])]
+    (-> ctx prtc/copy
+        (assoc-in [:data :parent] (memtag/uid-of ctx))
+        prtc/uncopy!)))

src/cljs/emptyhead/lib/core.cljs

@@ -1,6 +1,92 @@
 (ns emptyhead.lib.core
   "Core components of the stdlib."
-  (:require [emptyhead.thought.crud :as thought]))
+  (:require [emptyhead.thought.crud :as thought]
+            [emptyhead.thought.define :as def]
+            [emptyhead.idea.protocol :as prtc]
+            [emptyhead.idea.property :as prop]
+            [emptyhead.thought.eval :as eval]
+            [emptyhead.idea.memtag :as memtag]
+            [emptyhead.thought.extend :as extend]
+            [emptyhead.lib.io.print]
+            [emptyhead.lib.context]
+            [emptyhead.lib.compose]))
+
+(def/define! [:emptyhead :core :get-data]
+  (fn [thought parent]
+    [parent (prtc/val-fn :data parent)]))
+
+(def/define! [:emptyhead :core :return]
+  (fn [thought parent]
+    [parent (thought/data thought)])
+  :constr-fn
+  (fn [thought parent]
+    (let [[_ data] (thought/pop-stack parent)]
+      {:data data})))
+
+(def/define! [:emptyhead :core :nop]
+  (fn [thought parent]
+    [parent nil]))
+
+(def/define! [:emptyhead :core :add-ext-stage]
+  (fn [thought parent]
+    (let [[down stage] (thought/pop-stack parent)
+          [_ op] (thought/pop-stack down)
+          exe (prop/just-property op)]
+      (thought/add-ext-stage! exe stage)
+      [parent nil])))
+
+(def/define! [:emptyhead :core :add-prop]
+  (fn [thought parent]
+    (let [[down prop] (thought/pop-stack parent)
+          [_ op] (thought/pop-stack down)
+          exe (prop/just-property op)]
+      (prop/register-property! exe prop)
+      [parent nil])))
+
+(def/define! [:emptyhead :core :just-prop]
+  (fn [thought parent]
+    (let [[_ prop] (thought/pop-stack parent)]
+      [parent (memtag/uid-of (prop/just-property prop))])))
+
+(def/define! [:emptyhead :core :swap-stack]
+  (fn [thought parent]
+    (let [[parent first] (thought/pop-stack parent)
+          [parent second] (thought/pop-stack parent)]
+      [parent first second])))
+
+(def/define! [:emptyhead :core :gobble]
+  (fn [thought parent]
+    (let [[parent top] (thought/pop-stack parent)
+          [parent next] (if (sequential? top) (thought/pop-stack parent) [parent nil])
+          out (if (sequential? top) top (list top))
+          out (if next (cons next out) out)]
+      [parent out])))
+
+(def/define! [:emptyhead :core :execute]
+  (fn [thought parent]
+    (let [[parent top] (thought/pop-stack parent)
+          exe (prop/just-property top)]
+      [(eval/execute! exe parent) top])))
+
+(def/define! [:emptyhead :describe :print-stack]
+  (fn [thought parent]
+    (run! println (reverse (thought/stack parent)))
+    [parent nil]))
+
+(def/define! [:emptyhead :core :clear-stack]
+  (fn [thought parent]
+    [(assoc parent :return []) nil]))
+
+(def/define! [:emptyhead :core :extend]
+  (fn [thought parent]
+    (let [[down stage] (thought/pop-stack parent)
+          [_ op] (thought/pop-stack down)
+          exe (prop/just-property op)]
+      (extend/register-extension! exe stage)
+      [parent nil])))
+
+(def/define! [:emptyhead :core :pop]
+  (fn [thought parent]
+    (let [[parent _] (thought/pop-stack parent)]
+      [parent nil])))
 
-(defn data [data]
-  (thought/make-thought :emptyhead.core.data :data data))

src/cljs/emptyhead/lib/io/print.cljs

@@ -1,7 +1,15 @@
 (ns emptyhead.lib.io.print
   "Basic printing thoughts."
-  (:require [emptyhead.thought.define :as def]))
+  (:require [emptyhead.thought.define :as def]
+            [emptyhead.idea.protocol :as prtc]
+            [emptyhead.thought.crud :as thought]
+            [emptyhead.thought.eval :as eval]
+            [emptyhead.thought.extend :as extend]
+            [emptyhead.idea.property :as prop]
+            [emptyhead.idea.memtag :as memtag]))
+
+(def/define! [:emptyhead :io :print]
+  (fn [thought parent]
+    (-> parent prtc/value :return last println)
+    [parent nil]))
 
-; should this be [:emptyhead :io :print :print]? should internal and external namespaces match?
-(def/define! "emptyhead.io.print"
-  (fn [arg] (print arg)))

src/cljs/emptyhead/repl/core.cljs

@@ -0,0 +1,112 @@
+(ns emptyhead.repl.core
+  (:require [clojure.string :as str]
+            [emptyhead.thought.extend :as extend]
+            [emptyhead.thought.eval :as teval]
+            [emptyhead.idea.property :as prop]
+            [emptyhead.idea.protocol :as prtc]
+            [emptyhead.idea.memtag :as memtag]
+            [emptyhead.thought.define :as def]
+            [emptyhead.thought.crud :as thought]
+            [emptyhead.lib.core]
+            [emptyhead.lib.context :as ctx]))
+
+(defonce context (ctx/new-context))
+(defn clear-context [] (set! context (ctx/new-context)))
+
+(defn undot-operator [dotted-sym]
+  (mapv keyword (str/split (name dotted-sym) #"\.")))
+
+(defn eval! [thought & [parent]]
+  (set! context (teval/execute! thought parent)))
+
+(defn parse-command [cmd]
+  (cond
+    (= cmd '.BEGIN)         (thought/register-thought! [:emptyhead :repl :begin-block])
+    (= cmd '.END)           (thought/register-thought! [:emptyhead :repl :end-block])
+
+    (symbol? cmd)           (thought/register-thought!
+                             [:emptyhead :compose :append]
+                             :data (thought/register-thought! (undot-operator cmd)))
+
+    :else                   (thought/register-thought!
+                             [:emptyhead :compose :append]
+                             :data (thought/register-thought! [:emptyhead :core :return] :data cmd))))
+
+(def/define! [:emptyhead :repl :begin-block]
+  (fn [thought parent]
+    (let [ctx-creator (thought/register-thought! [:emptyhead :core :context :construct])
+          ;; Create a new context with `parent` as parent.
+          [parent ctx] (->> parent (teval/execute! ctx-creator) thought/pop-stack)
+          ctx (prop/just-property ctx)
+          ;; Make `parent` put the new context on its stack during its execution flow
+          ;; TODO refactor
+          parent (teval/execute! (thought/register-thought!
+                                  [:emptyhead :compose :append]
+                                  :data (thought/register-thought! [:emptyhead :core :return]
+                                                                   :data (memtag/uid-of ctx)))
+                                 parent)]
+
+      ;; NOTE `ctx` becomes the new `parent`!
+      [ctx
+       ctx])))
+
+(def/define! [:emptyhead :repl :end-block]
+  ;; Exiting context, so its parent becomes the new parent.
+  (fn [thought parent]
+    (let [parent-ctx (-> parent prtc/value :data :parent prop/just-property)]
+      [parent-ctx (memtag/uid-of parent)])))
+
+(defn read [& input]
+  (map parse-command input))
+
+(defn pprint-tos [thought]
+  (let [printer #(println (str "EMPTYHEAD> " %))
+        tos (-> thought prtc/value :return last)]
+    (-> tos printer)
+    tos))
+
+(defn run [& input]
+  (clear-context)
+  (run! #(eval! % context) (apply read input))
+  (pprint-tos context)
+  (prtc/reference (teval/execute! context context)))
+
+;; XXX an annoying class of bug is eg  forgetting the return value here, which yields just
+;; >No protocol method Idea.value defined for type null:
+;; In this case originationg from [[emptyhead.thought.eval/execute!]]
+;; Widely catching these errors earlier would be wise since we don't have
+;; a good stack trace for this stuff
+(def/define! [:emptyhead :debug :track]
+  (fn [thought parent]
+    (let [ctx (:_parent (prtc/value parent))]
+      (print "RUNNING " (:operator (prtc/value parent)) " ON ")
+      (print "CONTEXT " (prtc/reference ctx) " WITH ")
+      (print "STACK: ")
+      (print (:return ctx))
+      (print "\n\n")
+      [parent nil]
+      )))
+
+(def sample (thought/register-thought! [:foo]))
+
+;; XXX This has to have no stages otherwise it will loop on itself ww
+(defonce tracker (thought/register-thought! [:emptyhead :debug :track] :ext-stages [[:EXECUTE]]))
+
+(defn enable-tracking []
+  (extend/register-extension! tracker [:PRE-EXECUTE]))
+
+;; XXX accidentally registering one extension multiple times is a known footgun right now
+;; and probably needs some feature to prevent this
+;; (but mind that it shouldn't be *illegal*)
+;; Another issue is just general... garbage collection, that's a big thing
+(defn disable-tracking []
+  (map #(extend/remove-extension! % [:PRE-EXECUTE]) (extend/get-extensions [:PRE-EXECUTE])))
+
+;; FIXME something is going wrong with the context management here
+;; It would probably be good to name contexts somehow to keep easier track of them
+(def tst
+  '(.BEGIN
+    "hello"
+    emptyhead.io.print
+    .END
+    ))

src/cljs/emptyhead/thought/crud.cljs

@@ -7,27 +7,30 @@
             [emptyhead.contract.eval :as contract]
             [emptyhead.util.magic :as magic]))
 
+;; TODO groups
 (defn make-thought
   "Helper function to make thought object.
   You may want `register-thought!` instead."
   [operator & {:keys [data ext-contract ext-stages transient]
                :or {data {} ext-contract {}
-                    ext-stages [[:thought operator]]
+                    ext-stages [[:thought operator :pre] [:thought operator]
+                                [:PRE-EXECUTE] [:EXECUTE] [:POST-EXECUTE]
+                                [:thought operator :post]]
                     transient true}}]
   (hash-map :operator operator
             :data data
             :ext-contract ext-contract
             :ext-stages ext-stages
-            :return {}
+            :return []
             :transient (not (false? transient))))
 
 (defn register-thought!
   "Create a thought and register it in the state.
   Returns a reference to the created thought."
-  [operator & {:keys [data ext-contract ext-stages transient]
+  [operator & {:keys [data ext-contract ext-stages transient group]
                :as args}]
     (idea/have-idea!
-     :prefix (str "thought_" (magic/symbolize-ns operator) "_")
+     :prefix (str "emptyhead.thought#" (magic/symbolize-ns operator))
      :properties [magic/thought-ns]
      :data (make-thought operator args)))
 
@@ -48,3 +51,22 @@
   Returns the operator keyword."
   [thought]
   (prtc/val-fn :operator thought))
+
+(defn data
+  "Get the data field of a `thought`."
+  [thought]
+  (prtc/val-fn :data thought))
+
+(defn stack
+  [thought]
+  (prtc/val-fn :return thought))
+
+(defn pop-stack
+  [thought]
+  [(assoc thought :return (-> thought prtc/copy stack butlast vec)) (-> thought prtc/copy stack peek)])
+
+(def root-thought (make-thought :root))
+
+(defn add-ext-stage!
+  [thought stage]
+  (idea/mutate-idea! #(update % :ext-stages conj stage) thought))

src/cljs/emptyhead/thought/define.cljs

@@ -3,30 +3,40 @@
   (:require [emptyhead.thought.crud :as thought]
             [emptyhead.thought.eval :as eval]
             [emptyhead.idea.crud :as idea]
-            [emptyhead.util.magic :as magic]))
+            [emptyhead.util.magic :as magic]
+            [emptyhead.idea.memtag :as memtag]
+            [emptyhead.idea.protocol :as prtc]))
 
 (defn register-implementation!
   [operator impl]
-  (idea/have-idea! :prefix (str "impl_thought#" (magic/symbolize-ns operator))
+  (let [impl-prop (magic/thought-impl-prop operator)]
-                   :properties [(magic/thought-impl-prop operator)]
+    (idea/have-idea! :prefix (str "impl_thought#" (magic/symbolize-ns operator))
-                   :data {:implementation impl}))
+                     :properties [impl-prop]
+                     :shadowing [impl-prop]
+                     :data {:implementation impl})))
 
 (defn register-constructor!
   [operator & {:keys [constr-fn defaults]
-               :or {constr-fn identity
+               :or {constr-fn (fn [thought parent] {})
                     defaults {}}}]
   (let [constr-op (conj operator :construct)]
     (register-implementation!
      constr-op
      (fn [thought & [parent]]
-       [parent
+       (let [thought (prtc/value thought)
-       (thought/register-thought!
+             parent (prtc/value parent)]
-        operator
+         [parent
-        (merge defaults {:operator operator}
+          (memtag/uid-of
-               (constr-fn (merge parent thought))))]))))
+           (thought/register-thought!
+            operator
+            (merge defaults
+                   (thought/make-thought operator)
+                   {:data (thought/data thought)}
+                    (constr-fn thought parent)
+                   )))])))))
 
 (defn define!
   [operator impl & {:keys [constr-fn defaults]
                     :as constr-args}]
   (register-implementation! operator impl)
-  (register-constructor! operator constr-args))
+  (register-constructor! operator constr-args) )

src/cljs/emptyhead/thought/eval.cljs

@@ -17,29 +17,37 @@
                      {:thought thought :parent parent :type :unimplemented-thought})
       ((prtc/copy-fn :implementation impl-idea) thought parent))))
 
-(def root-thought (thought/make-thought :root))
 
-;; at what point do returns get cleared?
+
+  ;; FIXME I don't think omitting the parent here is actually valid?
+  ;; might need to use thought.crud/root-thought, but better making parent mandatory tabun
 (defn execute!
   "Execute `thought` with `parent`, applying aspects to `thought` according to its :extension-stages.
   Returns (potentially modified) `parent`."
   [thought & [parent]]
-  (loop [th (prtc/copy thought)
+
-         parent (or parent root-thought)]
+  ;; FIXME parent may change mid execution, breaking deep inspection
-    (let [cur (first (thought/stages thought))
+  (loop [th (assoc (prtc/value thought) :_parent (prtc/value parent))
+         parent parent]
+    (let [cur (first (thought/stages th))
           [extensions th] (extend/pop-stage th)
 
           ;; Execute extensions, potentially modifying th
           th (reduce #(execute! %2 %1) th extensions)
+
           ;; If it's time for `thought`'s implementation to run, do so,
           ;; potentially modifying `parent`.
-          [parent return]
+          [parent & returns]
-          (if (= cur [:thought (thought/operator th)])
+          (if (= cur [:EXECUTE]) ;; NOTE the magic value is now [:EXECUTE] since otherwise nothing could be bound to the global [:emptyhead] propspace
             (impl! th parent)
-            parent)
+            [parent nil])
 
           ;; Fold return value into `parent`.
-          parent (return/with-return parent (thought/operator th) return)]
+          parent (return/with-return parent returns)]
+
+                                        ; XXX FUCK IT WE BALL (??)
+      (prtc/uncopy! parent)
+      (prtc/uncopy! thought)
 
       ;; Recur if there's remaining aspects, otherwise return `parent`.
       (if (not-empty (thought/stages th))

src/cljs/emptyhead/thought/extend.cljs

@@ -6,7 +6,7 @@
             [emptyhead.util.magic :as magic]
             [clojure.set :refer [union]]))
 
-(defn register-extension
+(defn register-extension!
   "Register `thought` as extension for one or more `stages`."
   [thought & stages]
   (doseq [stage stages]
@@ -20,7 +20,7 @@
     (prop/remove-property! thought (magic/extension-prop stage)))
   thought)
 
-(defn- get-extensions
+(defn get-extensions
   "Get extensions for `stage`;
   e.g. for `stage` of [:foo :bar :baz], get extensions for [:foo :bar :baz], [:foo :bar], [:foo]"
   [stage]
@@ -31,6 +31,7 @@
       (recur (butlast property-segment)
              (union acc (prop/with-property (magic/extension-prop property-segment)))))))
 
+;; XXX contains references to scrapped "contract" subsys
 (defn extensions
   "Get extensions of `thought`.
   Returns a map of {stage => #{thought}}."
@@ -50,6 +51,10 @@
   (let [stages (thought/stages thought)
         aspects (filter #(contract/evaluate (thought/contract thought) %)
                         (get-extensions (first stages)))
+
+        ;; FIXME idk why this was here, but it's wrong--
+        ;; I've commented it out now, probably breaks something elsewhere!
+        ;; aspects (prop/with-property (magic/extension-prop (first stages)))
         modified (prtc/copy-fn #(assoc % :ext-stages (rest stages))
                           thought)]
     (list aspects modified)))

src/cljs/emptyhead/thought/return.cljs

@@ -3,10 +3,10 @@
   (:require [emptyhead.thought.crud :as thought]
             [emptyhead.idea.protocol :as prtc]))
 
-(defn with-return [thought namespace data]
+(defn with-return [thought data]
-  (if data
+  (if (first data)
-    (prtc/copy-fn
+    (prtc/val-fn
-     #(update-in % [:return namespace] (fnil conj []) data) thought)
+     #(update % :return (fnil into []) data) thought)
     thought))
 
 (defn return-vals [thought namespace]

src/cljs/miim/core/init.cljs

@@ -0,0 +1 @@
+(ns miim.core.init)

src/cljs/miim/graphics/pixi.cljs

@@ -0,0 +1,30 @@
+(ns miim.graphics.pixi
+  (:require ["pixi.js" :as PIXI]
+            [emptyhead.lib.io.print]
+            [emptyhead.thought.crud :as thought]
+            [emptyhead.thought.eval :as eval]
+            [emptyhead.idea.protocol :as prtc]
+            [emptyhead.thought.define :as def]))
+
+(def/define!
+  [:miim :graphics :make-screen]
+  (fn [thought parent]
+    (let [[parent args] (thought/pop-stack parent)
+          app (PIXI/Application.)]
+      (println args)
+      (-> (.init app (clj->js args))
+          (.then (fn [] (.appendChild js/document.body (.-canvas app)))))
+      [parent app])))
+
+(def populate
+   (thought/register-thought!
+    [:emptyhead :core :pure]
+    :data {:height 256 :width 256 :background "29028F"}))
+
+(def combined
+  (let [operations [populate (thought/register-thought! [:miim :graphics :make-screen])]
+        pure (eval/execute! (thought/register-thought! [:emptyhead :core :pure] :data operations))
+        meme (eval/execute! (thought/make-thought [:emptyhead :core :sequence])
+                            pure
+                            )]
+    (-> meme thought/pop-stack last)))