From 94c892d64d162db5e2d4af62686cfe58f851f646 Mon Sep 17 00:00:00 2001 From: Akko Date: Tue, 21 Jan 2025 19:11:39 +0100 Subject: [PATCH] stuff --- src/cljs/emptyhead/principle/crud.cljs | 50 +++++++++++++++ .../{thought => principle}/define.cljs | 21 ++++--- src/cljs/emptyhead/principle/eval.cljs | 46 ++++++++++++++ src/cljs/emptyhead/principle/extend.cljs | 61 +++++++++++++++++++ .../{thought => principle}/return.cljs | 0 src/cljs/emptyhead/thought/crud.cljs | 49 --------------- src/cljs/emptyhead/thought/eval.cljs | 45 -------------- src/cljs/emptyhead/thought/extend.cljs | 60 ------------------ src/cljs/emptyhead/util/magic.cljs | 14 +++++ 9 files changed, 182 insertions(+), 164 deletions(-) create mode 100644 src/cljs/emptyhead/principle/crud.cljs rename src/cljs/emptyhead/{thought => principle}/define.cljs (53%) create mode 100644 src/cljs/emptyhead/principle/eval.cljs create mode 100644 src/cljs/emptyhead/principle/extend.cljs rename src/cljs/emptyhead/{thought => principle}/return.cljs (100%) delete mode 100644 src/cljs/emptyhead/thought/crud.cljs delete mode 100644 src/cljs/emptyhead/thought/eval.cljs delete mode 100644 src/cljs/emptyhead/thought/extend.cljs create mode 100644 src/cljs/emptyhead/util/magic.cljs diff --git a/src/cljs/emptyhead/principle/crud.cljs b/src/cljs/emptyhead/principle/crud.cljs new file mode 100644 index 0000000..72a86f8 --- /dev/null +++ b/src/cljs/emptyhead/principle/crud.cljs @@ -0,0 +1,50 @@ +(ns emptyhead.principle.crud + "Implements CRUD operations on principles. + Since principles are ideas, 'missing' operations here are implemented in [[emptyhead.idea.crud]]." + (:require [emptyhead.idea.protocol :as prtc] + [emptyhead.idea.crud :as idea] + [emptyhead.idea.property :as prop] + [emptyhead.contract.eval :as contract] + [emptyhead.util.magic :as magic])) + +(defn make-principle + "Helper function to make principle object. + You may want `register-principle!` instead." + [operator & {:keys [data ext-contract ext-stages transient] + :or {data {} ext-contract {} + ext-stages [[:principle operator]] + transient true}}] + (hash-map :operator operator + :data data + :ext-contract ext-contract + :ext-stages ext-stages + :return {} + :transient (not (false? transient)))) + +(defn register-principle! + "Create a principle and register it in the state. + Returns a reference to the created principle." + [operator & {:keys [data ext-contract ext-stages transient] + :as args}] + (idea/have-idea! + :prefix (str "principle_" (name operator) "_") + :properties [magic/principle-ns] + :data (make-principle operator args))) + +(defn contract + "Get the extension contract of a `principle`. + Returns the contract." + [principle] + (prtc/val-fn :ext-contract principle)) + +(defn stages + "Get the extension stages of a `principle`. + Returns the list of stages." + [principle] + (prtc/val-fn :ext-stages principle)) + +(defn operator + "Get the operator id of a `principle`. + Returns the operator keyword." + [principle] + (prtc/val-fn :operator principle)) diff --git a/src/cljs/emptyhead/thought/define.cljs b/src/cljs/emptyhead/principle/define.cljs similarity index 53% rename from src/cljs/emptyhead/thought/define.cljs rename to src/cljs/emptyhead/principle/define.cljs index bef2cc7..7eecbb7 100644 --- a/src/cljs/emptyhead/thought/define.cljs +++ b/src/cljs/emptyhead/principle/define.cljs @@ -1,13 +1,14 @@ -(ns emptyhead.thought.define - "Utilities for defining new thoughts." - (:require [emptyhead.thought.crud :as thought] - [emptyhead.thought.eval :as eval] - [emptyhead.idea.crud :as idea])) +(ns emptyhead.principle.define + "Utilities for defining new principles." + (:require [emptyhead.principle.crud :as principle] + [emptyhead.principle.eval :as eval] + [emptyhead.idea.crud :as idea] + [emptyhead.util.magic :as magic])) (defn register-implementation! [operator impl] - (idea/have-idea! :prefix (str "impl_thought_" (name operator)) - :properties [[:thought-impl operator]] + (idea/have-idea! :prefix (str "impl_principle_" (name operator)) + :properties [(magic/principle-impl-prop operator)] :data {:implementation impl})) (defn register-constructor! @@ -17,12 +18,12 @@ (let [constr-op (keyword (str (name operator) ".construct"))] (register-implementation! constr-op - (fn [thought & [parent]] + (fn [principle & [parent]] [parent - (thought/register-thought! + (principle/register-principle! operator (merge defaults {:operator operator} - (constr-fn (merge parent thought))))])))) + (constr-fn (merge parent principle))))])))) (defn define! [operator impl & {:keys [constr-fn defaults] diff --git a/src/cljs/emptyhead/principle/eval.cljs b/src/cljs/emptyhead/principle/eval.cljs new file mode 100644 index 0000000..f74e900 --- /dev/null +++ b/src/cljs/emptyhead/principle/eval.cljs @@ -0,0 +1,46 @@ +(ns emptyhead.principle.eval + "Implements evaluation of principles." + (:require [emptyhead.idea.protocol :as prtc] + [emptyhead.principle.extend :as extend] + [emptyhead.principle.crud :as principle] + [emptyhead.util.logging :as logging] + [emptyhead.principle.return :as return] + [emptyhead.idea.property :as prop] + [emptyhead.idea.crud :as idea] + [emptyhead.util.magic :as magic])) + +(defn- impl! [principle & [parent]] + (let [impl-idea (prop/just-property (magic/principle-impl-prop (principle/operator principle)))] + (if-not impl-idea + (logging/error (str "No implementation for principle `" (principle/operator principle) "`.") + {:principle principle :parent parent :type :unimplemented-principle}) + ((prtc/copy-fn :implementation impl-idea) principle parent)))) + +(def root-principle (principle/make-principle :root)) + +;; at what point do returns get cleared? +(defn execute! + "Execute `principle` with `parent`, applying aspects to `principle` according to its :extension-stages. + Returns (potentially modified) `parent`." + [principle & [parent]] + (loop [th (prtc/copy principle) + parent (or parent root-principle)] + (let [cur (first (principle/stages principle)) + [extensions th] (extend/pop-stage th) + + ;; Execute extensions, potentially modifying th + th (reduce #(execute! %2 %1) th extensions) + ;; If it's time for `principle`'s implementation to run, do so, + ;; potentially modifying `parent`. + [parent return] + (if (= cur [:principle (principle/operator th)]) + (impl! th parent) + parent) + + ;; Fold return value into `parent`. + parent (return/with-return parent (principle/operator th) return)] + + ;; Recur if there's remaining aspects, otherwise return `parent`. + (if (not-empty (principle/stages th)) + (recur th parent) + parent)))) diff --git a/src/cljs/emptyhead/principle/extend.cljs b/src/cljs/emptyhead/principle/extend.cljs new file mode 100644 index 0000000..4815408 --- /dev/null +++ b/src/cljs/emptyhead/principle/extend.cljs @@ -0,0 +1,61 @@ +(ns emptyhead.principle.extend + (:require [emptyhead.contract.eval :as contract] + [emptyhead.idea.property :as prop] + [emptyhead.idea.protocol :as prtc] + [emptyhead.principle.crud :as principle] + [emptyhead.util.magic :as magic] + [clojure.set :refer [union]])) + +(defn register-extension + "Register `principle` as extension for one or more `stages`." + [principle & stages] + (doseq [stage stages] + (prop/register-property! principle (magic/extension-prop stage))) + principle) + +(defn remove-extension! + "Remove `principle` as extension for one or more `stages`." + [principle & stages] + (doseq [stage stages] + (prop/remove-property! principle (magic/extension-prop stage))) + principle) + +(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] + (loop [property-segment stage + acc []] + (if (empty? property-segment) + acc + (recur (butlast property-segment) + (union acc (prop/with-property (magic/extension-prop property-segment))))))) + +(defn extensions + "Get extensions of `principle`. + Returns a map of {stage => #{principle}}." + [principle] + (let [stages (principle/stages principle) + filter-fn #(contract/evaluate (principle/contract principle) %) + aspects (map + #(->> % get-extensions (filter filter-fn)) + stages)] + (zipmap stages aspects))) + +(defn pop-stage + "Get aspects of next stage of principle execution. + Returns a tuple of (#{extension-dhammas}, + a copy of `principle` with its first extension-stage removed)." + [principle] + (let [stages (principle/stages principle) + aspects (filter #(contract/evaluate (principle/contract principle) %) + (get-extensions (first stages))) + modified (prtc/copy-fn #(assoc % :ext-stages (rest stages)) + principle)] + (list aspects modified))) + +(defn has-stage? + "Return true if `principle` has extension stage `stage`. + Also works if e.g. `stage` is [:foo] and `principle` has [:foo :bar]." + [principle stage] + (some #(= stage (take (count stage) %)) (principle/stages principle))) diff --git a/src/cljs/emptyhead/thought/return.cljs b/src/cljs/emptyhead/principle/return.cljs similarity index 100% rename from src/cljs/emptyhead/thought/return.cljs rename to src/cljs/emptyhead/principle/return.cljs diff --git a/src/cljs/emptyhead/thought/crud.cljs b/src/cljs/emptyhead/thought/crud.cljs deleted file mode 100644 index 6b005c2..0000000 --- a/src/cljs/emptyhead/thought/crud.cljs +++ /dev/null @@ -1,49 +0,0 @@ -(ns emptyhead.thought.crud - "Implements CRUD operations on thoughts. - Since thoughts are ideas, 'missing' operations here are implemented in [[emptyhead.idea.crud]]." - (:require [emptyhead.idea.protocol :as prtc] - [emptyhead.idea.crud :as idea] - [emptyhead.idea.property :as prop] - [emptyhead.contract.eval :as contract])) - -(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]] - transient true}}] - (hash-map :operator operator - :data data - :ext-contract ext-contract - :ext-stages ext-stages - :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] - :as args}] - (idea/have-idea! - :prefix (str "thought_" (name operator) "_") - :properties [[:thought]] - :data (make-thought operator args))) - -(defn contract - "Get the extension contract of a `thought`. - Returns the contract." - [thought] - (prtc/val-fn :ext-contract thought)) - -(defn stages - "Get the extension stages of a `thought`. - Returns the list of stages." - [thought] - (prtc/val-fn :ext-stages thought)) - -(defn operator - "Get the operator id of a `thought`. - Returns the operator keyword." - [thought] - (prtc/val-fn :operator thought)) diff --git a/src/cljs/emptyhead/thought/eval.cljs b/src/cljs/emptyhead/thought/eval.cljs deleted file mode 100644 index 75148d9..0000000 --- a/src/cljs/emptyhead/thought/eval.cljs +++ /dev/null @@ -1,45 +0,0 @@ -(ns emptyhead.thought.eval - "Implements evaluation of thoughts." - (:require [emptyhead.idea.protocol :as prtc] - [emptyhead.thought.extend :as extend] - [emptyhead.thought.crud :as thought] - [emptyhead.util.logging :as logging] - [emptyhead.thought.return :as return] - [emptyhead.idea.property :as prop] - [emptyhead.idea.crud :as idea])) - -(defn- impl! [thought & [parent]] - (let [impl-idea (prop/just-property [:thought-impl (thought/operator thought)])] - (if-not impl-idea - (logging/error (str "No implementation for thought `" (thought/operator thought) "`.") - {: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? -(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)] - (let [cur (first (thought/stages thought)) - [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] - (if (= cur [:thought (thought/operator th)]) - (impl! th parent) - parent) - - ;; Fold return value into `parent`. - parent (return/with-return parent (thought/operator th) return)] - - ;; Recur if there's remaining aspects, otherwise return `parent`. - (if (not-empty (thought/stages th)) - (recur th parent) - parent)))) diff --git a/src/cljs/emptyhead/thought/extend.cljs b/src/cljs/emptyhead/thought/extend.cljs deleted file mode 100644 index 1b62c6c..0000000 --- a/src/cljs/emptyhead/thought/extend.cljs +++ /dev/null @@ -1,60 +0,0 @@ -(ns emptyhead.thought.extend - (:require [emptyhead.contract.eval :as contract] - [emptyhead.idea.property :as prop] - [emptyhead.idea.protocol :as prtc] - [emptyhead.thought.crud :as thought] - [clojure.set :refer [union]])) - -(defn register-extension - "Register `thought` as extension for one or more `stages`." - [thought & stages] - (doseq [stage stages] - (prop/register-property! thought [:_extends stage])) - thought) - -(defn remove-extension! - "Remove `thought` as extension for one or more `stages`." - [thought & stages] - (doseq [stage stages] - (prop/remove-property! thought [:_extends stage])) - thought) - -(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] - (loop [property-segment stage - acc []] - (if (empty? property-segment) - acc - (recur (butlast property-segment) - (union acc (prop/with-property [:_extends property-segment])))))) - -(defn extensions - "Get extensions of `thought`. - Returns a map of {stage => #{thought}}." - [thought] - (let [stages (thought/stages thought) - filter-fn #(contract/evaluate (thought/contract thought) %) - aspects (map - #(->> % get-extensions (filter filter-fn)) - stages)] - (zipmap stages aspects))) - -(defn pop-stage - "Get aspects of next stage of thought execution. - Returns a tuple of (#{extension-dhammas}, - a copy of `thought` with its first extension-stage removed)." - [thought] - (let [stages (thought/stages thought) - aspects (filter #(contract/evaluate (thought/contract thought) %) - (get-extensions (first stages))) - modified (prtc/copy-fn #(assoc % :ext-stages (rest stages)) - thought)] - (list aspects modified))) - -(defn has-stage? - "Return true if `thought` has extension stage `stage`. - Also works if e.g. `stage` is [:foo] and `thought` has [:foo :bar]." - [thought stage] - (some #(= stage (take (count stage) %)) (thought/stages thought))) diff --git a/src/cljs/emptyhead/util/magic.cljs b/src/cljs/emptyhead/util/magic.cljs new file mode 100644 index 0000000..f0cfa12 --- /dev/null +++ b/src/cljs/emptyhead/util/magic.cljs @@ -0,0 +1,14 @@ +(ns emptyhead.util.magic + "Magic values for EmptyHead.") + +(def principle-ns [:emptyhead :principle]) + +(def principle-impl-ns (conj principle-ns :implementation)) + +(defn principle-impl-prop [operator] + (conj principle-impl-ns operator)) + +(def extension-ns (conj principle-ns :extends)) + +(defn extension-prop [stage] + (conj extension-ns stage))