diff --git a/jolt-core/clojure/core/20-coll.clj b/jolt-core/clojure/core/20-coll.clj index 3f773c8..340af96 100644 --- a/jolt-core/clojure/core/20-coll.clj +++ b/jolt-core/clojure/core/20-coll.clj @@ -180,6 +180,81 @@ (defn file-seq [root] (tree-seq __dir? __list-dir root)) +;; --- Ad-hoc hierarchies (stage 3) — Clojure's canonical pure-map port. ----- +;; A hierarchy is {:parents {tag #{parents}} :ancestors {tag #{all}} +;; :descendants {tag #{all}}}. The 3-arity forms are PURE; the 1/2-arity forms +;; operate on the private global hierarchy atom. Multimethod dispatch +;; (evaluator defmulti-setup) calls isa? through the interned var. + +(defn make-hierarchy [] + {:parents {} :descendants {} :ancestors {}}) + +(def ^:private global-hierarchy (atom (make-hierarchy))) + +(defn isa? + ([child parent] (isa? (deref global-hierarchy) child parent)) + ([h child parent] + (or (= child parent) + (contains? (get (get h :ancestors) child #{}) parent) + (and (vector? parent) (vector? child) + (= (count parent) (count child)) + (loop [ret true i 0] + (if (or (not ret) (= i (count parent))) + ret + (recur (isa? h (nth child i) (nth parent i)) (inc i)))))))) + +(defn parents + ([tag] (parents (deref global-hierarchy) tag)) + ([h tag] (not-empty (get (get h :parents) tag)))) + +(defn ancestors + ([tag] (ancestors (deref global-hierarchy) tag)) + ([h tag] (not-empty (get (get h :ancestors) tag)))) + +(defn descendants + ([tag] (descendants (deref global-hierarchy) tag)) + ([h tag] (not-empty (get (get h :descendants) tag)))) + +(defn derive + ([tag parent] (swap! global-hierarchy derive tag parent) nil) + ([h tag parent] + (let [tp (get h :parents) + td (get h :descendants) + ta (get h :ancestors) + tf (fn [m source sources target targets] + (reduce (fn [ret k] + (assoc ret k + (reduce conj (get targets k #{}) + (cons target (get targets target))))) + m (cons source (get sources source))))] + (or + (when-not (contains? (get tp tag #{}) parent) + (when (contains? (get ta tag #{}) parent) + (throw (str tag " already has " parent " as ancestor"))) + (when (contains? (get ta parent #{}) tag) + (throw (str "Cyclic derivation: " parent " has " tag " as ancestor"))) + {:parents (assoc tp tag (conj (get tp tag #{}) parent)) + :ancestors (tf ta tag td parent ta) + :descendants (tf td parent ta tag td)}) + h)))) + +(defn underive + ([tag parent] (swap! global-hierarchy underive tag parent) nil) + ([h tag parent] + (let [parent-map (get h :parents) + childs-parents (if (get parent-map tag) + (disj (get parent-map tag) parent) + #{}) + new-parents (if (not-empty childs-parents) + (assoc parent-map tag childs-parents) + (dissoc parent-map tag)) + deriv-seq (mapcat (fn [e] (cons (key e) (interpose (key e) (val e)))) + (seq new-parents))] + (if (contains? (get parent-map tag #{}) parent) + (reduce (fn [p [t pr]] (derive p t pr)) + (make-hierarchy) (partition 2 deriv-seq)) + h)))) + ;; --- Stage 3 tier shrink: pure-over-core leaves moved off the Janet seed ---- ;; Representation predicates over the overlay's own predicates (no Janet reps). diff --git a/src/jolt/core.janet b/src/jolt/core.janet index 43bee0f..6d83b77 100644 --- a/src/jolt/core.janet +++ b/src/jolt/core.janet @@ -2313,36 +2313,6 @@ # intern is a ctx-capturing clojure.core fn now (install-stateful-fns!). # Hierarchy stubs for sci bootstrap -(def core-make-hierarchy make-hierarchy) -(defn core-derive - [& args] - (case (length args) - 2 (let [[tag parent] args] (derive* the-global-hierarchy tag parent) nil) - 3 (let [[h tag parent] args] (derive* h tag parent)))) -(defn core-isa? - [& args] - (case (length args) - 2 (let [[child parent] args] (isa? the-global-hierarchy child parent)) - 3 (let [[h child parent] args] (isa? h child parent)))) -(defn core-ancestors - [& args] - (case (length args) - 1 (apply make-phs (ancestors the-global-hierarchy (in args 0))) - 2 (let [[h tag] args] (apply make-phs (ancestors h tag))))) -(defn core-descendants - [& args] - (case (length args) - 1 (apply make-phs (descendants the-global-hierarchy (in args 0))) - 2 (let [[h tag] args] (apply make-phs (descendants h tag))))) -(defn core-parents - [& args] - (let [[h tag] (if (= 1 (length args)) [the-global-hierarchy (in args 0)] args) - p (get (h :parents) tag)] - (if p (make-phs p) (make-phs)))) -(defn core-underive [& args] - (case (length args) - 2 (let [[tag parent] args] (underive the-global-hierarchy tag parent) nil) - 3 (let [[h tag parent] args] (underive h tag parent)))) (def core-get-method (fn [mm-var dispatch-val] (let [methods (get mm-var :jolt/methods)] (or (get methods dispatch-val) (get methods :default))))) @@ -3229,13 +3199,6 @@ "reset!" core-reset! "swap!" core-swap! "not" core-not - "derive" core-derive - "isa?" core-isa? - "parents" core-parents - "ancestors" core-ancestors - "descendants" core-descendants - "make-hierarchy" core-make-hierarchy - "underive" core-underive "get-method" core-get-method "methods" core-methods "remove-method" core-remove-method diff --git a/src/jolt/evaluator.janet b/src/jolt/evaluator.janet index 1e66112..9d5138f 100644 --- a/src/jolt/evaluator.janet +++ b/src/jolt/evaluator.janet @@ -865,6 +865,7 @@ h)) (def ns (ctx-find-ns ctx (ctx-current-ns ctx))) (def methods @{}) + (def isa-cache @[nil]) (def dispatch-cache @{}) (def mm-fn (fn [& args] @@ -875,11 +876,24 @@ (let [cached (get dispatch-cache dv)] (if cached (apply cached args) - (let [h (or hierarchy the-global-hierarchy) + # isa? is the OVERLAY's (the hierarchy system is pure Clojure now, + # stage 3); resolve its var lazily, once. A :hierarchy option is an + # atom (deref per dispatch, like Clojure's var) or a plain map. + (let [isa-fn (do + (when (nil? (isa-cache 0)) + (put isa-cache 0 + (var-get (ns-find (ctx-find-ns ctx "clojure.core") "isa?")))) + (isa-cache 0)) + h (if hierarchy + (if (and (table? hierarchy) (= :jolt/atom (get hierarchy :jolt/type))) + (hierarchy :value) + hierarchy) + nil) found (do (var f nil) (var i 0) (let [ks (keys methods)] (while (and (nil? f) (< i (length ks))) - (if (isa? h dv (in ks i)) (set f (get methods (in ks i)))) + (if (if h (isa-fn h dv (in ks i)) (isa-fn dv (in ks i))) + (set f (get methods (in ks i)))) (++ i))) f)] (if found diff --git a/src/jolt/types.janet b/src/jolt/types.janet index 87ce951..54badeb 100644 --- a/src/jolt/types.janet +++ b/src/jolt/types.janet @@ -186,64 +186,6 @@ (put v :meta meta) meta) -(defn make-hierarchy - "Create a new empty hierarchy for multimethod dispatch." - [] - {:parents @{} :descendants @{} :ancestors @{}}) - -# The global hierarchy used by the 1/2-arg derive/isa?/parents/ancestors/ -# descendants and by multimethod dispatch when no explicit hierarchy is given. -(def the-global-hierarchy (make-hierarchy)) - -(defn derive* - "Add a parent relationship to a hierarchy." - [h tag parent] - (put (h :parents) tag parent) - (let [d (get (h :descendants) parent)] - (if d (array/push d tag) (put (h :descendants) parent @[tag]))) - (let [a (get (h :ancestors) tag)] - (if a (array/push a parent) (put (h :ancestors) tag @[parent]))) - h) - -(defn- ancestors* - "Internal: get all ancestors of a tag via iterative graph walk." - [h tag visited] - (var stack @[tag]) - (while (> (length stack) 0) - (let [t (array/pop stack)] - (when (not (get visited t)) - (put visited t true) - (let [p (get (h :parents) t)] - (when (and p (not= p t)) - (array/push stack p)))))) - visited) - -(defn ancestors - "Return all transitive ancestors of a tag in the given hierarchy." - [h tag] - (let [visited (ancestors* h tag @{})] - (var result @[]) - (loop [[k _] :pairs visited] - (when (not= k tag) (array/push result k))) - result)) - -(defn descendants - "Return the descendants of a tag in the given hierarchy." - [h tag] - (let [d (get (h :descendants) tag)] (if d d @[]))) - -(defn isa? - "Check if child is derived from parent in the given hierarchy." - [h child parent] - (if (= child parent) true - (let [p (get (h :parents) child)] - (if p (isa? h p parent) false)))) - -(defn underive - "Remove a parent relationship from a hierarchy." - [h tag parent] - (put (h :parents) tag nil) - h) (defn with-meta "Return a new var with updated metadata. The original var is unchanged." diff --git a/test/spec/hierarchy-spec.janet b/test/spec/hierarchy-spec.janet new file mode 100644 index 0000000..e6de89a --- /dev/null +++ b/test/spec/hierarchy-spec.janet @@ -0,0 +1,48 @@ +# Specification: ad-hoc hierarchies (make-hierarchy/derive/underive/isa?/ +# parents/ancestors/descendants) — ported to pure Clojure (stage 3). The +# 3-arity forms are PURE (derive returns a new hierarchy); the 1/2-arity forms +# use the global hierarchy. Multi-parent derive, transitive ancestors AND +# descendants, and vector-pair isa? match Clojure (the old Janet kernel had +# single-parent :parents and direct-only descendants). +(use ../support/harness) + +(defspec "hierarchy / pure 3-arity" + ["derive returns new h" "true" + "(let [h (derive (make-hierarchy) :rect :shape)] (and (map? h) (isa? h :rect :shape)))"] + ["original unchanged" "false" + "(let [h0 (make-hierarchy) h1 (derive h0 :rect :shape)] (isa? h0 :rect :shape))"] + ["isa? self" "true" "(isa? (make-hierarchy) :a :a)"] + ["isa? transitive" "true" + "(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (isa? h :square :shape))"] + ["multi-parent" "[true true]" + "(let [h (-> (make-hierarchy) (derive :sq :rect) (derive :sq :rhombus))] [(isa? h :sq :rect) (isa? h :sq :rhombus)])"] + ["parents set" "true" + "(let [h (-> (make-hierarchy) (derive :sq :rect) (derive :sq :rhombus))] (= #{:rect :rhombus} (parents h :sq)))"] + ["ancestors transitive" "true" + "(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (= #{:rect :shape} (ancestors h :square)))"] + ["descendants transitive" "true" + "(let [h (-> (make-hierarchy) (derive :square :rect) (derive :rect :shape))] (= #{:rect :square} (descendants h :shape)))"] + ["underive removes" "false" + "(let [h (-> (make-hierarchy) (derive :a :b) (underive :a :b))] (isa? h :a :b))"] + ["vector isa?" "true" + "(let [h (-> (make-hierarchy) (derive :rect :shape))] (isa? h [:rect :rect] [:shape :shape]))"] + ["vector isa? length" "false" + "(isa? (make-hierarchy) [:a] [:a :a])"] + ["cyclic derive throws" :throws + "(-> (make-hierarchy) (derive :a :b) (derive :b :a))"] + ["duplicate derive ok" "true" + "(let [h (-> (make-hierarchy) (derive :a :b) (derive :a :b))] (isa? h :a :b))"] + ["parents nil when none" "nil" "(parents (make-hierarchy) :x)"]) + +(defspec "hierarchy / global + multimethod dispatch" + ["global derive + isa?" "true" "(do (derive :gsq :grect) (isa? :gsq :grect))"] + ["global ancestors" "true" + "(do (derive :ga :gb) (derive :gb :gc) (contains? (ancestors :ga) :gc))"] + ["global underive" "false" + "(do (derive :gu :gv) (underive :gu :gv) (isa? :gu :gv))"] + ["dispatch via hierarchy" ":is-shape" + "(do (derive :hsq :hshape) (defmulti hmm identity) (defmethod hmm :hshape [_] :is-shape) (hmm :hsq))"] + ["dispatch custom hierarchy" ":parent" + "(do (def hh (atom (derive (make-hierarchy) :c :p))) (defmulti cmm identity :hierarchy hh) (defmethod cmm :p [_] :parent) (cmm :c))"] + ["dispatch exact beats isa" ":exact" + "(do (derive :de1 :de2) (defmulti emm identity) (defmethod emm :de2 [_] :parent) (defmethod emm :de1 [_] :exact) (emm :de1))"])