Skip to content

Commit d7e0108

Browse files
jclaggettjclaggett
committed
Begin to extract net from xfnet
1 parent 37b14a4 commit d7e0108

File tree

2 files changed

+118
-108
lines changed

2 files changed

+118
-108
lines changed

‎src/net/n01se/hassle/net.cljc

+104
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,104 @@
1+
(ns net.n01se.hassle.net)
2+
3+
(defn normalize-inputs [inputs]
4+
(if (set? inputs)
5+
(mapcat normalize-inputs inputs)
6+
(if (nil? inputs)
7+
(list)
8+
(list inputs))))
9+
10+
(defn normalize-net
11+
[label trees]
12+
(letfn [(walk-trees [net-map trees super-path]
13+
(reduce
14+
(fn [net-map [tree-type id sub-trees xf label]]
15+
(let [node-path [tree-type id]]
16+
(cond-> net-map
17+
(not (nil? xf))
18+
(assoc-in (conj node-path :xf) xf)
19+
20+
(not (nil? label))
21+
(assoc-in (conj node-path :label) label)
22+
23+
(not (or (= tree-type :output) (nil? super-path)))
24+
(-> (update-in (conj node-path :outputs) (fnil conj #{}) super-path)
25+
(update-in (conj super-path :inputs) (fnil conj #{}) node-path))
26+
27+
true
28+
(walk-trees sub-trees node-path))))
29+
net-map
30+
(normalize-inputs trees)))]
31+
(walk-trees {:label label} trees nil)))
32+
33+
(defn postwalk [net-xf roots update-fn]
34+
(let [orig-net-map (net-xf)
35+
kids (case roots :input :outputs :inputs)
36+
root-paths (for [k (-> orig-net-map roots keys)]
37+
[roots k])]
38+
39+
(letfn [(update-node [net-map path]
40+
(update-in
41+
net-map path
42+
(fn [node]
43+
(update-fn
44+
path node
45+
(for [kid-path (kids node)]
46+
(get-in net-map kid-path))))))
47+
48+
(visit-node [net-map path]
49+
(if (-> net-map meta ::visited (contains? path))
50+
net-map
51+
(-> net-map
52+
(vary-meta update ::visited conj path)
53+
(visit-nodes (get-in net-map (conj path kids)))
54+
(update-node path))))
55+
56+
(visit-nodes [net-map paths]
57+
(reduce visit-node net-map paths))]
58+
59+
(-> orig-net-map
60+
(vary-meta assoc ::visited #{})
61+
(visit-nodes root-paths)))))
62+
63+
(defn assert-no-outputs [inputs]
64+
(assert (->> inputs normalize-inputs (map first) (every? #{:input :node}))
65+
"Output nodes are not allowed as inputs")
66+
inputs)
67+
68+
(defn input [k] (list :input k #{}))
69+
(defn output [k inputs] (list :output k (assert-no-outputs inputs)))
70+
71+
(defn node* [label xf inputs]
72+
(list :node
73+
(gensym 'n)
74+
(assert-no-outputs inputs)
75+
xf
76+
label))
77+
78+
(defn embed [net-xf input-map]
79+
(-> net-xf
80+
(postwalk
81+
:output
82+
(fn [[node-type node-id] {xf :xf label :label} input-xfs]
83+
(condp = node-type
84+
:input (input-map node-id)
85+
:node (node* label xf (set input-xfs))
86+
:output (set input-xfs))))
87+
:output))
88+
89+
;; printing/debugging
90+
(defn compact-net-map [net-map]
91+
(letfn [(compact-paths [paths] (map second paths))]
92+
(concat
93+
(map (fn [[k {:keys [outputs]}]]
94+
[k :outputs (compact-paths outputs)])
95+
(:input net-map))
96+
(map (fn [[k {:keys [outputs inputs]}]]
97+
[k :outputs (compact-paths outputs) :inputs (compact-paths inputs)])
98+
(:node net-map))
99+
(map (fn [[k {:keys [inputs]}]]
100+
[k :inputs (compact-paths inputs)])
101+
(:output net-map)))))
102+
103+
(defn pr-net [net-xf]
104+
(compact-net-map (net-xf)))

‎src/net/n01se/hassle/xfnet.cljc

+14-108
Original file line numberDiff line numberDiff line change
@@ -1,71 +1,7 @@
11
(ns net.n01se.hassle.xfnet
2+
(:require [net.n01se.hassle.net :as net])
23
(:require [net.n01se.hassle.transducers :as t]))
34

4-
(defn normalize-inputs [inputs]
5-
(if (set? inputs)
6-
(mapcat normalize-inputs inputs)
7-
(if (nil? inputs)
8-
(list)
9-
(list inputs))))
10-
11-
(defn normalize-net
12-
[label trees]
13-
(letfn [(walk-trees [net-map trees super-path]
14-
(reduce
15-
(fn [net-map [tree-type id sub-trees xf label]]
16-
(let [node-path [tree-type id]]
17-
(cond-> net-map
18-
(not (nil? xf))
19-
(assoc-in (conj node-path :xf) xf)
20-
21-
(not (nil? label))
22-
(assoc-in (conj node-path :label) label)
23-
24-
(not (or (= tree-type :output) (nil? super-path)))
25-
(-> (update-in (conj node-path :outputs) (fnil conj #{}) super-path)
26-
(update-in (conj super-path :inputs) (fnil conj #{}) node-path))
27-
28-
true
29-
(walk-trees sub-trees node-path))))
30-
net-map
31-
(normalize-inputs trees)))]
32-
(walk-trees {:label label} trees nil)))
33-
34-
(defn postwalk [net-xf roots update-fn]
35-
(let [orig-net-map (net-xf)
36-
kids (case roots :input :outputs :inputs)
37-
root-paths (for [k (-> orig-net-map roots keys)]
38-
[roots k])]
39-
40-
(letfn [(update-node [net-map path]
41-
(update-in
42-
net-map path
43-
(fn [node]
44-
(update-fn
45-
path node
46-
(for [kid-path (kids node)]
47-
(get-in net-map kid-path))))))
48-
49-
(visit-node [net-map path]
50-
(if (-> net-map meta ::visited (contains? path))
51-
net-map
52-
(-> net-map
53-
(vary-meta update ::visited conj path)
54-
(visit-nodes (get-in net-map (conj path kids)))
55-
(update-node path))))
56-
57-
(visit-nodes [net-map paths]
58-
(reduce visit-node net-map paths))]
59-
60-
(-> orig-net-map
61-
(vary-meta assoc ::visited #{})
62-
(visit-nodes root-paths)))))
63-
64-
(defn assert-no-outputs [inputs]
65-
(assert (->> inputs normalize-inputs (map first) (every? #{:input :node}))
66-
"Output nodes are not allowed as inputs")
67-
inputs)
68-
695
(defn match-tags
706
([xf-map xs] (sequence (match-tags xf-map) xs))
717
([xf-map] (t/multiplex (map (fn [[k xf]]
@@ -77,7 +13,7 @@
7713
([net-xf xs] (sequence (make-net-xf net-xf) xs))
7814
([net-xf]
7915
(-> net-xf
80-
(postwalk
16+
(net/postwalk
8117
:input
8218
(fn [[node-type node-id] {:keys [xf inputs outputs]} output-xfs]
8319
(let [output-xfs' (if (empty? output-xfs) [identity] output-xfs)
@@ -93,22 +29,12 @@
9329
(defn net
9430
([label net-tree xs] (sequence (net net-tree) xs))
9531
([label net-tree]
96-
(let [net-map (normalize-net label net-tree)]
32+
(let [net-map (net/normalize-net label net-tree)]
9733
^:xfn
9834
(fn transducer
9935
([] net-map)
10036
([rf] ((make-net-xf transducer) rf))))))
10137

102-
(defn input [k] (list :input k #{}))
103-
(defn output [k inputs] (list :output k (assert-no-outputs inputs)))
104-
105-
(defn node* [label xf inputs]
106-
(list :node
107-
(gensym 'n)
108-
(assert-no-outputs inputs)
109-
xf
110-
label))
111-
11238
(defmacro node [xf inputs]
11339
(let [label (if (sequential? xf)
11440
(if (symbol? (first xf))
@@ -122,17 +48,6 @@
12248
(str xf))]
12349
`(node* '~label ~xf ~inputs)))
12450

125-
(defn embed [net-xf input-map]
126-
(-> net-xf
127-
(postwalk
128-
:output
129-
(fn [[node-type node-id] {xf :xf label :label} input-xfs]
130-
(condp = node-type
131-
:input (input-map node-id)
132-
:node (node* label xf (set input-xfs))
133-
:output (set input-xfs))))
134-
:output))
135-
13651
(defrecord Passive [x]
13752
clojure.lang.IDeref
13853
(deref [_] x))
@@ -157,30 +72,21 @@
15772
;; The nodes defined here are mislabeled for readability. Short term fix.
15873
;; Longer term, join should be represented as a subnet.
15974
(let [active-inputs? (mapv active? inputs)]
160-
(node*
75+
(net/node*
16176
'join
16277
(t/join-index-tags active-inputs?)
16378
(->> inputs
16479
(map active)
16580
(map-indexed
166-
#(node* (if (active-inputs? %1) 'active 'passive)
167-
(t/tag %1)
168-
%2))
81+
#(net/node*
82+
(if (active-inputs? %1) 'active 'passive)
83+
(t/tag %1)
84+
%2))
16985
set))))
17086

171-
;; printing/debugging
172-
(defn compact-net-map [net-map]
173-
(letfn [(compact-paths [paths] (map second paths))]
174-
(concat
175-
(map (fn [[k {:keys [outputs]}]]
176-
[k :outputs (compact-paths outputs)])
177-
(:input net-map))
178-
(map (fn [[k {:keys [outputs inputs]}]]
179-
[k :outputs (compact-paths outputs) :inputs (compact-paths inputs)])
180-
(:node net-map))
181-
(map (fn [[k {:keys [inputs]}]]
182-
[k :inputs (compact-paths inputs)])
183-
(:output net-map)))))
184-
185-
(defn pr-net [net-xf]
186-
(compact-net-map (net-xf)))
87+
;; Re-export these for now
88+
(def input net/input)
89+
(def output net/output)
90+
(def node* net/node*)
91+
(def embed net/embed)
92+
(def postwalk net/postwalk)

0 commit comments

Comments
 (0)