(ns ai.logical.knotwork)
;;;;; --------------------------- HELPER FUNCTIONS
;;;;----------------------------------------------
(defn alter [m k f & args]
(assoc m k (apply f (get m k) args)))
(defn alter-in [m [k & ks] f & args]
(assoc-in m (cons k ks)
(apply f (get-in m (cons k ks)) args)))
(defn substitute
"Replace the components of x with their corresponding value in the map m."
[m x]
(cond (map? x)
(zipmap (map (partial substitute m) (keys x))
(map (partial substitute m) (vals x)))
(set? x)
(set (map (partial substitute m) x))
(vector? x)
(vec (map (partial substitute m) x))
(coll? x)
(map (partial substitute m) x)
:else
(get m x x)))
;;;;---------------------------------------------------------
;;;;; --------------------------- DEFINITION OF CUBE GEOMETRY
;;;;---------------------------------------------------------
(def cube-vertices [1 2 3 4 5 6 7 8])
(def cube-midpoints [:a :b :c :d :e :f :g :h :i :j :k :l])
(def vertices-to-midpoints
{ #{1 2} :a,
#{2 3} :b,
#{3 4} :c,
#{4 1} :d,
#{1 5} :e,
#{2 6} :f,
#{3 7} :g,
#{4 8} :h,
#{8 5} :i,
#{5 6} :j,
#{6 7} :k,
#{7 8} :l})
(defn cycle-1
"Remove the first element of the list and append it to the end (or
do nothing if the list is empty.)"
[coll]
(when coll
(concat (rest coll) (take 1 coll))))
(defn cyclic
"Append the first element of list to the end (or do nothing if the
list is empty.)"
[coll]
(concat coll (take 1 coll)))
(defn permutation-from-cycles
"Given a single list, returns a map from each object to its neighbor,
wrapping around. Given multiple lists, computes the individual maps and
merges them."
[& cycles]
(into {}
(map #(zipmap % (cycle-1 %)) cycles)))
(def rotate-1
(permutation-from-cycles
[1 2 3 4]
[5 6 7 8]
[:a :b :c :d]
[:e :f :g :h]
[:i :j :k :l]))
(def rotate-2
(permutation-from-cycles
[2 6 7 3]
[1 5 8 4]
[:b :f :k :g]
[:a :j :l :c]
[:e :i :h :d]))
(def rotate-3
(permutation-from-cycles
[1 2 6 5]
[4 3 7 8]
[:a :f :j :e]
[:b :k :i :d]
[:c :g :l :h]))
(def reflect-1
(permutation-from-cycles
[1 2]
[3 4]
[5 6]
[7 8]
[:a :a]
[:c :c]
[:j :j]
[:l :l]
[:b :d]
[:e :f]
[:g :h]
[:i :k]))
(def cube-rotations
"A list of substitution maps representing all possible rigid,
non-reflecting symmetries of the cube."
(let [points (keys rotate-1)
no-op (zipmap points points)]
(loop [open [no-op] closed #{}]
(if-let [x (first open)]
(if (closed x)
(recur (rest open) closed)
(recur (concat (rest open)
(for [xform [rotate-1 rotate-2 rotate-3]]
(zipmap (keys x) (substitute xform (vals x)))))
(conj closed x)))
closed))))
(def cube-rotations-reflections
"A list of substitution maps representing all possible rigid,
symmetries of the cube, including reflections."
(let [points (keys rotate-1)
no-op (zipmap points points)]
(loop [open [no-op] closed #{}]
(if-let [x (first open)]
(if (closed x)
(recur (rest open) closed)
(recur (concat (rest open)
(for [xform [rotate-1 rotate-2 rotate-3 reflect-1]]
(zipmap (keys x) (substitute xform (vals x)))))
(conj closed x)))
closed))))
(def positive-crossings
"A list of all positively-signed, plus-shaped crossings on a cube
face."
(distinct
(map #(substitute % {:over [#{:a :b} #{:c :d}], :under [#{:a :d} #{:b :c}]})
cube-rotations)))
;;;;---------------------------------------------------------
;;;;; --------------------------- KNOTWORK CONFIGURATIONS AGAIN:
;;;;; --------------------------- WRAPPING BANDS AROUND FACES WITH REFLECTION
;;;;---------------------------------------------------------
(comment :unused defn distinct-symmetries
"Return a subcollection of coll that are all distinct with respect to
the substitution maps in symmetries."
[symmetries coll]
(loop [coll coll, seen #{}, return nil]
(if-let [x (first coll)]
(if (seen x)
(recur (rest coll)
seen
return)
(recur (rest coll)
(into seen
(for [xform (conj symmetries nil)] ;; include identity as nil
(substitute xform x)))
(conj return x)))
return)))
(def cube-knotwork-configurations
"Find all unique ways of wrapping string around the faces in a particular
way, accounting for rotational symmetries."
(let [faces [[1 2 3 4]
[2 6 7 3]
[5 8 7 6]
[1 4 8 5]
[3 7 8 4]
[1 5 6 2]]
face-labels [:A1 :A2,
:B1 :B2]
rotate-face-label (permutation-from-cycles [:A1 :A2]
[:B1 :B2])
;; Rotate the face's vertices until the lowest-numbered vertex is listed first.
;; Change the face label to its rotated counterpart accordingly.
canonicalize (fn [[face config]]
(->> [face config]
(iterate (fn [[x y]] [(cycle-1 x) (substitute rotate-face-label y)]))
(take (count face))
(filter (comp (partial = (apply min face)) ffirst))
first
))
canonicalize* #(into {} (map canonicalize %))
expand (fn [solution] (distinct (map canonicalize*
(for [xform cube-rotations]
(substitute xform solution)))))
]
(loop [agenda [{:open (rest faces), :assignment {(first faces) :A1}}], seen #{}, return nil]
;;(println (first agenda) (count seen))
(if-let [configuration (first agenda)]
(if-let [face (first (:open configuration))]
(recur (concat
(for [label face-labels]
(-> configuration
(alter :open rest)
(alter :assignment
#(assoc % face label))))
(rest agenda))
(into seen (expand (:assignment configuration))),
return)
(let [solution (canonicalize* (:assignment configuration))]
(if-not (seen solution)
(recur (rest agenda)
(into seen
(distinct
(map canonicalize*
(for [xform cube-rotations]
(substitute xform solution)))))
(conj return solution))
(recur (rest agenda) seen return))))
return))))
;;;;----------------------------------------------------------------
;;;;; --------------------------- COMPUTE THREE-COLORINGS
;;;;----------------------------------------------------------------
;; For this kind of cube configuration, it is enough to assign every
;; edge of the cube a color.
;; (let [faces [[1 2 3 4]
;; [2 6 7 3]
;; [5 8 7 6]
;; [1 4 8 5]
;; [3 7 8 4]
;; [1 5 6 2]]
(defn tricolorations [config]
(let [config (canonicalize-face-labels config)
faces (keys config)
edges (mapcat (comp (partial map set) (partial partition 2 1) cyclic) (keys config))
constraint-check?
(fn [assignment [a b c d :as face]]
(or
;; all three colors are used on this face
(and (= (get assignment #{a b})
(get assignment #{c d}))
(not= (get assignment #{a b})
(get assignment #{b c}))
(not= (get assignment #{a b})
(get assignment #{a d}))
(not= (get assignment #{b c})
(get assignment #{a d})))
;; all colors are the same on this face
(= (get assignment #{a b})
(get assignment #{b c})
(get assignment #{c d})
(get assignment #{d a}))))
valid-assignment?
(fn [assignment]
(and (every?
(fn [[a b c d :as face]]
(if (not-any? nil? (map (partial get assignment)
[#{a b} #{b c} #{c d} #{d a}]))
(constraint-check? assignment [a b c d])
true))
faces)
))
]
(loop [stack [{:open edges, :assignment {}}], results nil]
(if-let [problem (first stack)]
(if (valid-assignment? (:assignment problem))
(if-let [x (first (:open problem))]
(recur (concat (for [color [:red :green :blue]]
(-> problem
(alter :open rest)
(alter :assignment
#(assoc % x color))))
(rest stack))
results)
(if (> (count (distinct (vals (:assignment problem)))) 1)
(recur (rest stack) (conj results (:assignment problem)))
(recur (rest stack) results)
)
)
(recur (rest stack) results))
results))))
(defn plausible-tricolor? [config]
;; test whether k = 3^n - 3
(let [config* (directed-face-labels config)
n (count (segments-join-disoriented (thread-segments config)))
colorations (count (tricolorations config))]
(and (= n 1) (= 0 colorations))
(or (and (zero? colorations) (= n 1))
(and (= 6 colorations) (= n 2))
(and (= 24 colorations) (= n 3))
(and (= 78 colorations) (= n 4))))
)
(comment :example
"How many of these configurations have the same
tricolorability as an unlink?"
(count (filter plausible-tricolor? cube-knotwork-configurations))
;; Answer:
73
)
(comment :example
"What if we further restrict the number of threads to 1,
based on what we found with crossing number?"
;; Answer:
30
)
(comment :example
"Thread counts and number of tricolorations for all 216 cube configurations"
(frequencies (map (juxt
(comp count segments-join-disoriented thread-segments)
(comp count tricolorations))
cube-knotwork-configurations))
([[1 0] 30] ;; plausible 1-unlink
[[1 6] 24]
[[1 24] 7]
[[2 0] 43]
[[2 6] 36] ;; plausible 2-unlink
[[2 24] 11]
[[3 0] 26]
[[3 6] 21]
[[3 24] 7] ;; plausible 3-unlink
[[4 0] 5]
[[4 6] 4]
[[4 24] 2]))
;;;;----------------------------------------------------------------
;;;;; --------------------------- CONVERTING FACE LABELS TO THREADS
;;;;; --------------------------- AND COMPUTING CROSSING NUMBER
;;;;----------------------------------------------------------------
(defn canonicalize-face-labels
"Given an assignment of labels to cube faces, cyclically permute each
face's vertices until all the face labels are type :A1 or :B1."
[config]
(let [rotate-face-label
(permutation-from-cycles [:A1 :A2]
[:B1 :B2])
;; Rotate the face's vertices (and the accompanying label) until the face label is :P.
;; Note that this is a different canonicalization that the one in cube-knotwork-configurations.
canonicalize
(fn [[face config]]
(->> [face config]
(iterate (fn [[x y]]
[(vec (cycle-1 x)) (substitute rotate-face-label y)]))
(take (count face))
(filter (comp #{:A1 :B1} second)) ;; new canonicalization
first))]
(into {} (map canonicalize config))))
(defn thread-segments [config]
"Return a list of directed thread segments in the face-labeled
knotwork. The direction of the segment is chosen so that it crosses
first under, then over, the other thread on its face.
(A thread segment is defined by an ordered pair of edges that share
a vertex. An edge is an unordered pair of vertices.)"
[config]
(let [config* (canonicalize-face-labels config)
faces (keys config*)]
(reduce concat
(for [[a b c d :as face] (keys config*)]
(if (= (get config* face) :A1)
(list [#{a b} #{b c}]
[#{c d} #{d a}])
(list [#{b a} #{a d}]
[#{d c} #{c b}]))))))
(defn segments-join-disoriented
"Join a list of segments like [a b] [b c] [d c] into contiguous
chains that are as long as possible, reversing segments if
necessary."
[segments]
(let [other (fn [x [y z]] (if (= x y) z y))]
(loop [open segments,
closed nil]
(if-let [thread (first open)]
(if-let [x (first
(filter (comp (partial some (partial = (last thread))) identity)
(rest open)))]
(recur
(cons (conj thread (other (last thread) x)) (remove #{thread, x} open))
(conj closed))
(recur
(rest open)
(conj closed thread)))
closed))))
(defn subthread-sign
"If subthread occurs as a sublist within thread, return +1. Otherwise, if subthread
occurs /reversed/ within thread, return -1. Return nil if not found."
[sub thread]
(let [sub (seq sub)
threads
(->> thread
(iterate cycle-1)
(take (count thread))
(map (partial take (count sub))))]
(cond (some (partial = sub) threads) 1,
(some (partial = (reverse sub)) threads) -1)))
(defn linking-numbers
"Return a map associating each pair of threads in the knotwork with
their (signed) linking number."
[config]
(let [config* (canonicalize-face-labels config)
segments (thread-segments config*)
threads (segments-join-disoriented segments)
;; every distinct unordered pair of threads
crossing-pairs (distinct (for [x threads, y threads :when (not= x y)]
(set [x y])))
]
(loop [crossings (partition 2 segments), ;;! segments are ordered in such a way that every pair of adjacent segments is a crossing.
crossing-counts (zipmap crossing-pairs (repeat 0))]
(if-let [[x y] (first crossings)]
(let [thread-1 (first (filter (partial subthread-sign x) threads))
thread-2 (first (filter (partial subthread-sign y) threads))
sign-1 (subthread-sign x thread-1)
sign-2 (subthread-sign y thread-2)]
(cond (or (nil? thread-1) (nil? thread-2))
(throw (Error.))
(= thread-1 thread-2)
(recur (rest crossings)
(assoc crossing-counts #{thread-1} 0))
(= sign-1 sign-2)
(recur (rest crossings)
(alter crossing-counts #{thread-1 thread-2} inc))
(not= sign-1 sign-2)
(recur (rest crossings)
(alter crossing-counts #{thread-1 thread-2} dec)))
)
crossing-counts
))))
;;;;;
(defn directed-face-labels
"Adjust the face labels (A1,B1) to incorporate a globally-consistent
(but arbitrary) thread direction.
P is standard, with a north-to-east thread and a south-to-west thread.
Q has the north-to-east thread reversed.
R has the south-to-west thread reversed.
S has both reversed.
Their vertical-mirror images are P',Q',R',S'.
"
[config]
(let [config* (canonicalize-face-labels config)
threads (segments-join-disoriented (thread-segments config*))]
(loop [faces (keys config*), config config*]
(if-let [[a b c d :as face] (first faces)]
(let [reflected? (= (get config face) :B1)
segment-1 (if-not reflected? [#{a b} #{b c}] [#{b a} #{a d}])
segment-2 (if-not reflected? [#{c d} #{d a}] [#{d c} #{c b}])
thread-1 (first (filter (partial subthread-sign segment-1) threads))
thread-2 (first (filter (partial subthread-sign segment-2) threads))
sign-1 (subthread-sign segment-1 thread-1)
sign-2 (subthread-sign segment-2 thread-2)
]
(recur (rest faces)
(assoc config (first faces)
(if-not reflected?
(cond (and (= 1 sign-1) (= 1 sign-2)) :P
(and (= -1 sign-1) (= 1 sign-2)) :Q
(and (= 1 sign-1) (= -1 sign-2)) :R
(and (= -1 sign-1) (= -1 sign-2)) :S
:else [:error thread-1 thread-2]
)
;; TODO: double check that the reflection names are right.
(cond (and (= 1 sign-1) (= 1 sign-2)) :P'
(and (= -1 sign-1) (= 1 sign-2)) :Q'
(and (= 1 sign-1) (= -1 sign-2)) :R'
(and (= -1 sign-1) (= -1 sign-2)) :S'
:else [:error thread-1 thread-2]
)))))
config))))
(comment :example
(take 30 (map directed-face-labels cube-knotwork-configurations)))
;;;;----------------------------------------------------------------------
;;;;; --------------------------- TREE DATA STRUCTURES
;;;;----------------------------------------------------------------------
(defn tree-decompose
"Abstract tree-building function. If (is-leaf? x) determines that the
object x is basic, make-leaf-fn converts a basic x into the appropriate leaf
datatype. Otherwise, the function ramify turns a nonbasic x into a list of subobjects
to be recursively decomposed into trees, while make-tree takes any number of
subtrees and forms a tree data type."
[is-leaf? make-leaf-fn ramify make-tree-fn x]
(let [recur* (partial tree-decompose is-leaf? make-leaf-fn ramify make-tree-fn)]
(if (is-leaf? x)
(make-leaf-fn x)
(apply make-tree-fn (map recur* (ramify x))))))
(defn tree-map
"Abstract recursive tree modification.
If x is a leaf (as determined by is-leaf?), returns (g x).
Otherwise, recursively applies to each of (branches x),
and combines them using (apply f ...) ."
[is-leaf? branches f g x]
(if (is-leaf? x) (g x)
(apply f
(map (partial tree-map is-leaf? branches f g) (branches x)))))
;;;;----------------------------------------------------------------
;;;;; --------------------------- KNOT SIMPLIFICATIONS I:
;;;;; --------------------------- SIMPLIFYING EACH FACE INDIVIDUALLY
;;;;----------------------------------------------------------------
(def config-skein-relations
(list
[:P :U1 :W1]
[:V1 :X1 :Q]
[:V3 :X3 :R]
[:S :W2 :U2]
[:P' :W1 :U1]
[:V2 :Y1 :Q']
[:V4 :Y3 :R']
[:S' :U2 :W2]
))
(comment def face-labels
(let [a :a, b :b, c :c, d :d]
{:U1
{:segments [[#{d c} #{c b}] [#{a b} #{a d}]]
:crossings nil},
:U2
{:segments [[#{b c} #{b a}] [#{d a} #{d c}]]
:crossings nil},
:V1
{:segments [[#{d c} #{d a}] [#{b c} #{b a}]]
:crossings nil},
:V3
{:segments [[#{d a} #{d c}] [#{b a} #{b c}]]
:crossings nil},
:W1
{:segments [[#{d c} #{d a}] [#{b a} #{b c}]]
:crossings nil},
:W2
{:segments [[#{a d} #{a b}] [#{c b} #{c d}]]
:crossings nil},
:X1
{:segments [[#{b c} #{a d}] [#{c d} #{b a}]]
:crossings [{:over [#{b c} #{a d}], :under [#{c d} #{b a}]}]},
:X3
{:segments [[#{a d} #{b c}] [#{a b} #{c d}]]
:crossings [{:over [#{a d} #{b c}], :under [#{a b} #{c d}]}]}
:Y1
{:segments [[#{a d} #{b c}] [#{c d} #{a b}]]
:crossings [{:over [#{a d} #{b c}], :under [#{c d} #{a b}]}]
},
:Y3
{:segments [[#{b c} #{a d}] [#{a b} #{c d}]]
:crossings [{:over [#{b c} #{a d}], :under [#{a b} #{c d}]}]
}
}))
(defn unknot-faces
"Decompose the cube knotwork into a tree of simpler knotworks such that each face has at most one crossing.
Uses skein relations to make these three-part decompositions.
Face labels: U2, U3 (clockwise strands)
V1, V3 (parallel strands)
W1, W2 (anticlockwise strands)
P (standard double-crossed strands)
X1, X3 (X-shaped negative crossing)"
([config]
(let [config (-> config
canonicalize-face-labels
directed-face-labels )]
(tree-decompose
(fn is-leaf? [config] (or (nil? config)
(nil?
(first
(filter
(comp #{:P :Q :R :S,
:P' :Q' :R' :S'}
val) config)))))
(fn make-leaf-fn [x]
(when x x) ;;(knotwork-finish (thread-info x)))
)
(fn ramify [config]
(let [[face label]
(first (filter (comp #{:P :Q :R :S,
:P' :Q' :R' :S'} val) config))
changed-label (fn [label] (assoc config face label))]
(if-let [relation
(first (filter #(some (partial = label) %) config-skein-relations))]
(->> relation
(substitute {label nil})
(mapv #(when-not (nil? %) (changed-label %))))
false)))
vector ;; make-tree-fn
config))))
(comment :example
(unknot-faces (first cube-knotwork-configurations)))
(defn explode-tree [x]
(tree-map #(or (nil? %) (map? %))
identity
concat
#(when % [%])
x))
(def cube-knotwork-plausible
(lazy-seq
(->> cube-knotwork-configurations
(filter (comp (partial every? zero?) vals linking-numbers))
(filter (comp zero? count tricolorations))
;;(map canonicalize-face-labels)
;;(map directed-face-labels)
;;(map unknot-faces)
;; debug: determine all face labels used in any deconstruction
;; (map (partial tree-map #(or (nil? %) (map? %)) identity (comp distinct concat) vals))
;;reverse
)))
(defn thread-data
"Given a cube with face labels (such as :U2 :W3), return a map of thread
:segments and knot :crossings."
[directed-config]
(apply merge-with concat
(map (fn [[face label]]
(substitute (zipmap [:a :b :c :d] face)
(get face-labels label)))
directed-config)))
(let [_ :example]
"Compute the skein-relation tree for all the
plausible (i.e. single-thread) knots."
(->> cube-knotwork-plausible
(map unknot-faces)
(map (partial tree-map
#(or (nil? %) (map? %))
identity
vector
#(when % ((comp count segments-join-disoriented :segments thread-data) %))))
(take 3))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;; POLYNOMIAL ARITHMETIC
;;; A univariate polynomial is a list [a0 a1 a2 ... an] representing
;;; a0 + a_1 z + a_2 z^2 + a3 z^3 + ... + a_n z^n
;; A polynomial in k variables is a map from exponents [c1 c2 c3 ... ck] to coefficients.
(defn polynomial-add [p1 p2]
(merge-with + p1 p2))
(defn polynomial-multiply [p1 p2]
(for [exponent-1 (keys p1)
exponent-2 (keys p2)]
{(vec (map + exponent-1 exponent-2))
(* (get p1 exponent-1)
(get p2 exponent-2))}))
(defn polynomial-divide [p1 p2])
;; (defn polynomial-add [p1 p2]
;; ((fn loop [p1 p2]
;; (if (and (empty? p1) (empty? p2)) '()
;; (lazy-seq
;; (cons (+ (or (first p1) 0)
;; (or (first p2) 0))
;; (loop (rest p1) (rest p2))))))
;; p1 p2))
;; (defn polynomial-multiply [p1 p2]
;; (let [p1* (lazy-cat p1 (repeat 0)),
;; p2* (lazy-cat p2 (repeat 0))
;; product-coefficients
;; (->>
;; (for [i (range (count p1))
;; j (range (count p2))]
;; { (+ i j), (* (nth p1* i) (nth p2* j))})
;; (apply merge-with +))
;; ]
;; (for [k (range (inc (apply max (keys product-coefficients))))]
;; (get product-coefficients k 0))))
(comment (map unknot-faces cube-knotwork-plausible))
;;;;---------------------------------------------------------
;;;;; --------------------------- KNOTWORK CONFIGURATIONS:
;;;;; --------------------------- WRAPPING BANDS AROUND FACES
;;;;---------------------------------------------------------
(comment "RESULT: OUT OF 4^6 = 4096 nominal configurations, there are
actually only 192 distinct configurations after accounting for
configurations that are rotations of one another.")
(def cube-knotwork-configurations
"Find all unique ways of wrapping string around the faces in a particular
way, accounting for rotational symmetries."
;; The four possible face labels will be labeled P Q R S, in clockwise rotational order.
(let [faces [[1 2 3 4]
[2 6 7 3]
[5 8 7 6]
[1 4 8 5]
[3 7 8 4]
[1 5 6 2]]
face-labels [:P :P2 :P3 :P4] ;; P, P2, P3, P4 are all clockwise rotations of the same knotwork shape.
rotate-face-label (permutation-from-cycles (reverse face-labels))
;; Rotate the face's vertices until the lowest-numbered vertex is listed first.
;; Change the face label to its rotated counterpart accordingly.
canonicalize (fn [[face config]]
(->> [face config]
(iterate (fn [[x y]] [(cycle-1 x) (substitute rotate-face-label y)]))
(take (count face))
(filter (comp (partial = (apply min face)) ffirst))
first
))
canonicalize* #(into {} (map canonicalize %))
]
(loop [agenda [{:open faces, :assignment {}}], seen #{}, return nil]
(if-let [configuration (first agenda)]
(if-let [face (first (:open configuration))]
(recur (concat (rest agenda)
(for [label face-labels]
(-> configuration
(alter :open rest)
(alter :assignment
#(assoc % face label)))))
seen, return)
(let [solution (canonicalize* (:assignment configuration))]
(if-not (seen solution)
(recur (rest agenda)
(into seen
(distinct
(map canonicalize*
(for [xform cube-rotations]
(substitute xform solution)))))
(conj return solution))
(recur (rest agenda) seen return))))
return))))
(defn canonicalize-face-labels
"Given an assignment of labels to cube faces, cyclically permute each face's
vertices until all the face labels are type :P."
[config]
(let [face-labels [:P :P2 :P3 :P4]
rotate-face-label (permutation-from-cycles (reverse face-labels))
;; Rotate the face's vertices (and the accompanying label) until the face label is :P.
;; Note that this is a different canonicalization that the one in cube-knotwork-configurations.
canonicalize
(fn [[face config]]
(->> [face config]
(iterate (fn [[x y]]
[(vec (cycle-1 x)) (substitute rotate-face-label y)]))
(take (count face))
(filter (comp (partial = :P) second)) ;; new canonicalization
first))]
(into {} (map canonicalize config))))
(defn thread-segments [config]
"Return a list of directed thread segments in the knotwork. The
direction of the segment is chosen so that it crosses first under, then
over, the other thread on its face.
(A thread segment is defined by an ordered pair of edges that share a
vertex. An edge is an unordered pair of vertices.)"
[config]
(let [config* (canonicalize-face-labels config)
faces (keys config*)]
(mapcat (fn [[v1 v2 v3 v4]] (list [#{v1 v2} #{v2 v3}] [#{v3 v4} #{v4 v1}]))
faces)))
(comment
(let [face-labels [:P :P2 :P3 :P4]
rotate-face-label (permutation-from-cycles (reverse face-labels))
;; Rotate the face's vertices (and the accompanying label) until the face label is :P.
;; Note that this is a different canonicalization that the one in cube-knotwork-configurations.
canonicalize
(fn [[face config]]
(->> [face config]
(iterate (fn [[x y]] [(cycle-1 x) (substitute rotate-face-label y)]))
(take (count face))
(filter (comp (partial = :P) second)) ;; new canonicalization
first))
canonicalize* #(into {} (map canonicalize %))
faces (keys (canonicalize* config))]
(mapcat (fn [[v1 v2 v3 v4]] (list [#{v1 v2} #{v2 v3}] [#{v3 v4} #{v4 v1}]))
faces)))
(defn segments-join
"Join segments like [a b] [b c] [d c] into contiguous chains that are as long as possible, reversing segments if necessary."
[segments]
(let [other (fn [x [y z]] (if (= x y) z y))]
(loop [open segments,
closed nil]
(if-let [thread (first open)]
(if-let [x
(first (filter (comp (partial some (partial = (last thread))) identity) (rest open)))]
(recur
(cons (conj thread (other (last thread) x)) (remove #{thread, x} open))
(conj closed))
(recur
(rest open)
(conj closed thread)))
closed))))
(defn threads
"Return a list of distinct threads in the knotwork. Threads are represented
as cyclic lists of edges (unordered vertex pairs)."
[config]
(segments-join (thread-segments config)))
(comment "Thread counts for the 192 distinct knotwork configurations."
(frequencies (sort (map (comp count threads) cube-knotwork-configurations)))
:=>result {1 56, 2 80, 3 48, 4 8})
(def threads* "Return a list of distinct threads in the generalized knotwork."
(comp segments-join :segments))
(defn subthread-sign
"If subthread occurs as a sublist within thread, return +1. Otherwise, if subthread
occurs /reversed/ within thread, return -1. Return nil if not found."
[sub thread]
(let [sub (seq sub)
threads
(->> thread
(iterate cycle-1)
(take (count thread))
(map (partial take (count sub))))]
(cond (some (partial = sub) threads)
1,
(some (partial = (reverse sub)) threads)
-1)))
(defn crossing-numbers
"Return a map associating each pair of threads in the knotwork with
their crossing number."
[config]
(let [config* (canonicalize-face-labels config)
segments (thread-segments config*)
threads (segments-join-disoriented segments)
;; every distinct unordered pair of threads
crossing-pairs (distinct (for [x threads, y threads :when (not= x y)]
(set [x y])))
]
(loop [crossings (partition 2 segments), ;;! segments are ordered in such a way that every pair of adjacent segments is a crossing.
crossing-counts (zipmap crossing-pairs (repeat 0))]
(if-let [[x y] (first crossings)]
(let [thread-1 (first (filter (partial subthread-sign x) threads))
thread-2 (first (filter (partial subthread-sign y) threads))
sign-1 (subthread-sign x thread-1)
sign-2 (subthread-sign y thread-2)]
(cond (or (nil? thread-1) (nil? thread-2))
(recur (rest crossings) crossing-counts)
(= thread-1 thread-2)
(recur (rest crossings)
(assoc crossing-counts #{thread-1} 0))
(= sign-1 sign-2)
(recur (rest crossings)
(alter crossing-counts #{thread-1 thread-2} inc))
(not= sign-1 sign-2)
(recur (rest crossings)
(alter crossing-counts #{thread-1 thread-2} dec)))
)
crossing-counts
))))
(comment
"It turns out that every multiple-thread link has some threads with nonzero crossings, ergo none of them are an unlink."
"The only possible unlinks are the single-thread knots, of which there are 56 distinct instances."
(sort-by (comp (partial apply +) (partial map #(Math/abs %))) (map (comp vals crossing-numbers) cube-knotwork-configurations))
)
(defn all-zero-crossings? [config]
(every? zero? (map #(Math/abs %) (vals (crossing-numbers config)))))
;;;;----------------------------------------------------------------------
;;;;; --------------------------- GENERAL KNOTWORKS
;;;;; --------------------------- DEFINING KNOTWORKS EXPLICITLY IN TERMS OF SEGMENTS AND CROSSINGS.
;;;;----------------------------------------------------------------------
;;;;;;; cube-knotwork-configurations ==> config (P1, P2, P3, P4)
;;;;;;; ==directed-face-labels=========> directed config (P, Q, R, S)
;;;;;;; config (P1,P2,P3,P4) ==unknot-faces=========> simplified directed config (U3, W2)
;;;;;;; ===========thread-info========> thread configuration (:segments, :crossings)
;;;;;;; ===========chain-cycle========> chain (cyclic? list of :crossings)
;; rename: thread-info -> knotwork? chain-cycle => ordered-crossings? uncross-faces => unknot-faces?
;;; NOTE: The functions that produce general knotworks are defined later.
(def face-labels
(let [a :a, b :b, c :c, d :d,
e [a b c d :e], f [d c b a :f]]
{:U3
{:segments [[#{d c} #{c b}] [#{a b} #{a d}]]
:crossings nil},
:U2
{:segments [[#{b c} #{b a}] [#{d a} #{d c}]]
:crossings nil},
:V1
{:segments [[#{d c} #{d a}] [#{b c} #{b a}]]
:crossings nil},
:V3
{:segments [[#{d a} #{d c}] [#{b a} #{b c}]]
:crossings nil},
:W1
{:segments [[#{d c} #{d a}] [#{b a} #{b c}]]
:crossings nil},
:W2
{:segments [[#{a d} #{a b}] [#{c b} #{c d}]]
:crossings nil},
:X1
{:segments [[#{b c} #{a d}] [#{c d} #{b a}]]
:crossings [{:over [#{b c} #{a d}], :under [#{c d} #{b a}]}]
},
:X3
{:segments [[#{a d} #{b c}] [#{a b} #{c d}]]
:crossings [{:over [#{a d} #{b c}], :under [#{a b} #{c d}]}]
},
:U1
{:segments [[#{d c} #{c b}] [#{a b} #{a d}]]
:crossings nil},
:Y1
{:segments [[#{a d} #{b c}] [#{c d} #{a b}]]
:crossings [{:over [#{a d} #{b c}], :under [#{c d} #{a b}]}]
},
:Y3
{:segments [[#{b c} #{a d}] [#{a b} #{c d}]]
:crossings [{:over [#{b c} #{a d}], :under [#{a b} #{c d}]}]
},
:P
{:segments [ [#{a b} #{e}]
[#{e} #{b c}]
[#{c d} #{f}]
[#{f} #{d a}]]
:crossings [{:under [#{a b} #{e}], :over [#{f} #{d a}]}
{:under [#{c d} #{f}], :over [#{e} #{b c}]}]
},
:Q
{:segments [[#{b c} #{e}]
[#{e} #{a b}]
[#{c d} #{f}]
[#{f} #{d a}]]
:crossings [{:under [#{e} #{a b}], :over [#{f} #{d a}]}
{:under [#{c d} #{f}], :over [#{b c} #{e}]}]
},
:S
{:segments [ [#{b c} #{e}]
[#{e} #{a b}]
[#{d a} #{f}]
[#{f} #{c d}]
]
:crossings [{:under [#{e} #{a b}], :over [#{d a} #{f}]}
{:under [#{f} #{c d}], :over [#{b c} #{e}]}]
},
:R
{:segments [[#{a b} #{e}]
[#{e} #{b c}]
[#{d a} #{f}]
[#{f} #{c d}]]
:crossings [{:under [#{a b} #{e}], :over [#{d a} #{f}]}
{:under [#{f} #{c d}], :over [#{e} #{b c}]}]
},
:P'
{:segments [ [#{b a} #{e}]
[#{e} #{a d}]
[#{d c} #{f}]
[#{f} #{c b}]]
:crossings [{:under [#{b a} #{e}], :over [#{f} #{c b}]}
{:under [#{d c} #{f}], :over [#{e} #{a d}]}]
},
:Q'
{:segments [[#{a d} #{e}]
[#{e} #{b a}]
[#{d c} #{f}]
[#{f} #{c b}]]
:crossings [{:under [#{e} #{b a}], :over [#{f} #{c b}]}
{:under [#{d c} #{f}], :over [#{a d} #{e}]}]
},
:S'
{:segments [ [#{a d} #{e}]
[#{e} #{b a}]
[#{c b} #{f}]
[#{f} #{d c}]
]
:crossings [{:under [#{e} #{b a}], :over [#{c b} #{f}]}
{:under [#{f} #{d c}], :over [#{a d} #{e}]}]
},
:R'
{:segments [[#{b a} #{e}]
[#{e} #{a d}]
[#{c b} #{f}]
[#{f} #{d c}]]
:crossings [{:under [#{b a} #{e}], :over [#{c b} #{f}]}
{:under [#{f} #{d c}], :over [#{e} #{a d}]}]
},
:A1
{:segments [ [#{a b} #{e}]
[#{e} #{b c}]
[#{c d} #{f}]
[#{f} #{d a}]]
:crossings [{:under [#{a b} #{e}], :over [#{f} #{d a}]}
{:under [#{c d} #{f}], :over [#{e} #{b c}]}]
},
:B1
{:segments [[#{a b} #{e}]
[#{e} #{d a}]
[#{c d} #{f}]
[#{f} #{b c}]]
:crossings [{:under [#{a b} #{e}], :over [#{f} #{b c}]}
{:under [#{c d} #{f}], :over [#{e} #{d a}]}]
}
}
))
(defn thread-info
"Given a cube with face labels (such as :U2 :W3), return a map of thread
:segments and knot :crossings."
[directed-config]
(apply merge-with concat
(map (fn [[face label]]
(substitute (zipmap [:a :b :c :d] face) (get face-labels label)))
directed-config)))
(comment
(map (comp thread-info directed-face-labels) (filter all-zero-crossings? cube-knotwork-configurations))
)
;;;;----------------------------------------------------------------------
;;;;; --------------------------- KNOT SIMPLIFICATIONS
;;;;; --------------------------- REIDEMEISTER MOVES DETANGLE GENERAL KNOTS.
;;;;----------------------------------------------------------------------
;;; rename? -> traverse-crossings
(comment defn crossing-chain
"Given a map of segments and crossings of a /single/ self-intersecting thread,
traverse the thread and list the crossings (and :over / :under) in order.
(The function thread-info produces suitable input for this function.)"
[m]
(let [thread (first (segments-join (:segments m)))
crossings (:crossings m)
crossing-type-here (fn [[seg-1 seg-2]]
(first
(remove nil?
(for [component [:over :under]
x crossings]
;;[component x [seg-1 seg-2]]
(if (= (component x) [seg-1 seg-2])
{:type component, :crossing x}
)))))
]
(->> thread (partition 2 1)
(map crossing-type-here)
(remove nil?)
;;(#(concat % (take 1 %))) ;; complete the cycle by appending first elt to the end.
)))
(def segments-join segments-join-disoriented)
;; TODO: Does each segment have at most one crossing??
(defn crossing-at [thread-data segment]
(first (filter #(contains? (set (vals %)) segment)
(:crossings thread-data))))
(defn traverse-crossings
"Given a map of segments and crossings of a (possibly multi-component) knotwork,
traverse the threads and list the crossings (including :over / :under) in order.
(The function thread-info produces suitable input for this function.)"
[thread-data]
(for [thread (segments-join (:segments thread-data))]
(->> thread
(partition 2 1)
(map (juxt identity (partial crossing-at thread-data)))
(map (fn [[segment crossing]]
(when crossing
{:crossing crossing,
:type (if (= (:over crossing) segment) :over :under)})))
(remove nil?)
)))
(comment :example
(crossing-chain
(directed-threads-with-crossings (uncross-faces (first cube-knotwork-configurations)))))
(defn prefixes [coll]
"Return a seq of the first 0, 1, 2, 3, ... elements of coll, up to coll itself."
((fn loop [n]
(let [x (take n coll)]
(cond (empty? coll) '(())
(= x coll) x
:else
(lazy-seq (cons x (loop (inc n)))))))
0))
(defn subthreads
"Return a list of all subthreads delimited by crossings."
[thread-data]
(let [delimiters (set (mapcat (juxt :over :under) (:crossings thread-data)))
extend (fn [x] (some #(when (= (second x) (first %)) %) (:segments thread-data)))
]
(if (empty? delimiters) ;; knotwork consists of unbroken loops
(segments-join (:segments thread-data))
(for [x delimiters]
(->> (iterate extend x) ;; complete thread starting from x
(prefixes) ;; thread prefixes starting from x
(nnext)
(drop-while (comp #(and (not (nil? %))
(not (delimiters %)))
last))
(first))))))
(comment :example
(first (map (comp subthreads thread-data directed-face-labels canonicalize-face-labels) cube-knotwork-plausible)))
(defn subthreads* ;; rename -> threads-between ?
"Return a list of all subthreads delimited by crossings."
[thread-data]
(let [delimiters (set (mapcat (juxt :over :under) (:crossings thread-data)))
extend (fn [x] (some #(when (= (second x) (first %)) %) (:segments thread-data)))
take-after (fn [pred coll] (let [[before after] (split-with pred coll)] (concat before (take 1 after))))
;; _ (clojure.pprint/pprint thread-data)
]
(if (empty? delimiters) (segments-join (:segments thread-data))
(for [x delimiters]
(->> (iterate extend x)
(rest)
(remove nil?)
(take-after (comp not delimiters))
(cons x))))))
(defn delete-thread-between
"Delete the directed thread between the two segments, inclusive,
along with the associated endpoint crossings."
[thread-data segment-1 segment-2]
(if-let [thread
(first
(filter
(fn [sub]
(and
(= segment-1 (first sub))
(= segment-2 (last sub))))
(subthreads thread-data)))
]
(let [crossing-1 (crossing-at thread-data segment-1)
crossing-2 (crossing-at thread-data segment-2)
;;_ (println thread)
]
(-> thread-data
(alter :segments (partial remove (set thread)))
(alter :crossings (partial remove (set [crossing-1 crossing-2]))))
)
thread-data
))
(comment :example
(let [x {:segments (list [#{4 3} #{1 4}]
[#{1 2} #{3 2}]
[#{7 6} #{7 3}]
[#{3 2} #{6 2}]
[#{6 5} #{7 8}]
[#{5 8} #{7 6}]
[#{1 4} #{5 8}]
[#{4 8} #{1 5}]
[#{7 3} #{4 8}]
[#{7 8} #{4 3}]
[#{1 5} #{1 2}]
[#{6 2} #{6 5}]),
:crossings (list {:over [#{6 5} #{7 8}], :under [#{5 8} #{7 6}]}
{:over [#{1 4} #{5 8}], :under [#{4 8} #{1 5}]}
{:over [#{7 3} #{4 8}], :under [#{7 8} #{4 3}]})}]
(delete-thread-between x [#{4 8} #{1 5}] [#{6 5} #{7 8}])
))
(comment defn thread-between
"Return the subthread that starts with segment-1 and ends with
segment-2, inclusive and directed."
[thread-data segment-1 segment-2]
(let [heads (take (count thread) (iterate cycle-1 thread))]
(->> (filter (comp (partial = (seq segment-1)) (partial take 2)) heads)
(first)
(cyclic)
(partition 2 1)
(take-while (comp (partial not= (seq segment-2)) first))
(map first)
(#(concat % [segment-2]))
)))
(defn reidemeister-1-crossings
"List all of the ordered segment endpoints that can be removed by a
reidemeister-1 move, i.e. ➰ -> —"
[thread-info]
(let [crossing-pairs (mapcat (partial partition 2 1)
(map cyclic (traverse-crossings thread-info)))]
(for [[cross-1 cross-2] crossing-pairs
:when (= (:crossing cross-1) (:crossing cross-2))]
(list ((:type cross-1) (:crossing cross-1))
((:type cross-2) (:crossing cross-2))))))
(defn reidemeister-2-crossings
"List all the ordered crossing pairs that can be removed by a
reidemeister-2 move, i.e. ꘉ -> ||"
;; Rule: two crossings occur consecutively with the same over/under type, then occur consecutively later in the thread."
[thread-info]
(let [crossing-pairs (mapcat (partial partition 2 1)
(map cyclic (traverse-crossings thread-info)))]
(distinct
(for [[cross-1 cross-2] crossing-pairs
[cross-3 cross-4] crossing-pairs
:when (and (= :over (:type cross-1) (:type cross-2))
(= :under (:type cross-3) (:type cross-4))
(or (and (= (:crossing cross-1) (:crossing cross-3))
(= (:crossing cross-2) (:crossing cross-4)))
(and (= (:crossing cross-1) (:crossing cross-4))
(= (:crossing cross-2) (:crossing cross-3)))))]
[(:crossing cross-1) (:crossing cross-2)]))))
;; The real one
(defn knotwork-simplify
"Simplify the knotwork using reidemeister transforms."
[thread-data]
(let [thread-data* thread-data
thread-data*
(loop [thread-data thread-data*,
crossing-pairs (reidemeister-2-crossings thread-data*)]
(if-let [[cross-1 cross-2] (first crossing-pairs)]
(let [x
(-> thread-data
(alter :crossings (partial remove (set [cross-1 cross-2]))))]
(recur x (reidemeister-2-crossings x)))
thread-data))
thread-data*
(loop [thread-data thread-data*,
segment-pairs (reidemeister-1-crossings thread-data*)]
(if-let [[seg-1 seg-2] (first segment-pairs)]
(let [x
(-> thread-data
(delete-thread-between seg-1 seg-2)
(alter :segments #(conj % [(first seg-1) (second seg-2)])))]
(recur x (reidemeister-1-crossings x)))
thread-data))
]
(if (= thread-data* thread-data) thread-data* (recur thread-data*))))
(defn invert-crossing
"Change the crossing type from positive to negative or vice-versa."
([c] (assoc c
:over (get c :under),
:under (get c :over)))
([thread-data c]
(-> thread-data
(alter :crossings
(partial map #(if (= c %) (invert-crossing c) %)))
(alter :transformed
#(conj % (invert-crossing c))))))
(defn neutralize-crossing
"Delete the crossing, then reconnect the four endpoints to form
non-crossing parallel strands."
[thread-data c]
(-> thread-data
(alter :crossings (partial remove (partial = c)))
(alter :segments
#(remove (set (vals c)) %))
(alter :segments
#(conj % [(first (:over c)) (second (:under c))]
[(first (:under c)) (second (:over c))]))
(alter :transformed #(conj % c))
))
;; the knotworks should now transiently keep track of the knots that have already been
;; transformed so as not to enter a loop. :transformed
(defn knotwork-finish
[thread-data]
"Given thread data for a knotwork, decompose it into a tree of
atomic knotworks using skein relations."
(tree-decompose
(fn is-leaf? [x] (every? (set (:transformed x)) (:crossings x)))
(fn make-leaf-fn [x] (when x (if (empty (:crossings x)) x false)))
(fn ramify [x]
(if-let [crossing (first (remove (set (:transformed x)) (:crossings x)))]
(if ((set positive-crossings) crossing)
[nil
(knotwork-simplify (neutralize-crossing x crossing))
(knotwork-simplify (invert-crossing x crossing))]
[(knotwork-simplify (invert-crossing x crossing))
(knotwork-simplify (neutralize-crossing x crossing))
nil])))
vector
(knotwork-simplify thread-data)
))
(comment defn knotwork-finish [thread-data]
(tree-decompose
(fn is-leaf? [thread-data] (or true (empty? (:crossings thread-data))
(empty? (remove (set(:transformed thread-data)) (:crossings thread-data)))))
;; (or (empty? (:crossings thread-data))) )
(fn make-leaf-fn [x] [x])
(fn ramify [thread-data]
(if-let [x (first (remove (set (:transformed thread-data)) (:crossings thread-data)))]
(if ((set positive-crossings) x)
[nil
(knotwork-simplify (neutralize-crossing x crossing))
(knotwork-simplify (invert-crossing x crossing))]
[(knotwork-simplify (invert-crossing x crossing))
(knotwork-simplify (neutralize-crossing x crossing))
nil])))
vector
thread-data
))
(comment :observation
"The exploded components of the cube knots have at most four crossings."
(frequencies (map (comp count :crossings) (mapcat explode-components cube-knotwork-configurations)))
{0 8228, 1 1536, 2 1704, 3 736, 4 84}
"Pre-simplifying the knotwork with reidemeister transforms shifts down some of the crossing counts.
Interestingly, none of the four-crossings have any reidemeister simplifications.
"
(frequencies (map (comp count :crossings knotwork-simplify) (mapcat explode-components cube-knotwork-configurations)))
{0 10558, 1 84, 2 1278, 3 284, 4 84}
)
;
; (defn knotwork-simplify
; "Simplify the knotwork using reidemeister transforms."
; [thread-data]
; (let [thread-data*
; (reduce (fn [thread-data [[seg-1 seg-2] [seg-3 seg-4]]]
; (alter thread-data
; :crossings
; (fn [crossings]
; (filter
; #(empty? (clojure.set/intersection
; (set [seg-1 seg-2 seg-3 seg-4])
; (set (vals %))))
; crossings))))
; (reidemeister-2-crossings thread-data))
;
; thread-data*
; (reduce (fn [thread-data [seg-1 seg-2]]
; (-> thread-data
; (delete-thread-between seg-1 seg-2)
; (alter :crossings (partial remove (partial = (crossing-at thread-data seg-1))))
; (alter :segments #(conj % [(first seg-1) (second seg-2)]))))
;
;
; ]
;
;
; (if (= thread-data* thread-data) thread-data*
; (recur thread-data*))))
;
;(defn knotwork-simplify
; [thread-data]
;
; (let [thread-data* thread-data
;
; thread-data*
; ;; APPLY ALL AVAILABLE REIDEMEISTER-1 TRANSFORMS
; (alter thread-data* :crossings
; (->> thread-data*
; (reidemeister-1-crossings)
; (reduce concat)
; (set)
; (partial remove)))
;
; thread-data*
; ;; APPLY ALL AVAILABLE REIDEMEISTER-2 TRANSFORMS
; (alter thread-data* :crossings
; (->> thread-data*
; (reidemeister-2-crossings)
; (reduce concat)
; (set)
; (partial remove)))
;
;
;
; ]
;
;
; (if (= thread-data* thread-data)
; thread-data*
; (recur thread-data*))))
(comment defn reidemeister-1-crossings
"List all of the ordered crossing pairs that can be removed by a
reidemeister-1 move, i.e. ➰ -> —"
[chain]
(->> chain
(cyclic)
(partition 2 1)
;; when the same crossing occurs twice in a row, it's a type-1 crossing.
(map (fn [[x y]] (when (= (:crossing x) (:crossing y)) [x y])))
(remove nil?) ))
(comment defn reidemeister-2-crossings
"List all the ordered crossing pairs that can be removed by a
reidemeister-2 move, i.e. ꘉ -> ||"
;; Rule: two crossings occur consecutively with the same over/under type, then occur consecutively later in the thread."
[chain]
(for [[[cross-1 cross-2] & cross-pairs]
(->> chain
(iterate cycle-1)
(take (count chain))
(map (partial partition 2 1))
)
:when (= (:type cross-1) (:type cross-2))
]
[:yep (:type cross-1) (:type cross-2) cross-1 cross-2]
))
(defn simpler-knotwork? [x y]
(< (count (:crossings x)) (count (:crossings y))))
;; (defn knotwork-simplify
;; "Apply reidemeister transformations to simplify the knotwork."
;; [thread-info]
;; (cond (empty? (:crossings thread-info))
;; thread-info
;; (not (empty? (reidemeister-1-moves thread-info)))
;; (recur (reduce apply-reidemeister-1
;; thread-info
;; (reidemeister-1-moves thread-info)))
;; (not (empty? (reidemeister-2-moves thread-info)))
;; (recur (reduce apply-reidemeister-2
;; thread-info
;; (reidemeister-2-moves thread-info)))
;; :else
;; thread-info))
;; (defn unknot-complete
;; "Decompose the cube knotwork into a tree of simpler knotworks that have no crossings.
;; Uses skein relations to make these three-part decompositions.
;; Knotwork at this final stage is presented as a map of {:segments, :crossings}.
;; "
;; [thread-info]
;; (tree-decompose
;; (fn is-leaf? [info] (or (nil? info) (empty? (:crossings info))))
;; (fn make-leaf-fn [x] x)
;; (fn ramify [info]
;; )
;; vector ;; make-tree-fn
;; thread-info)
;; )
;;;;----------------------------------------------------------------------
;;;;; --------------------------- SKEIN RELATIONS I:
;;;;; --------------------------- MAKE EACH FACE HAVE AT MOST ONE CROSSING
;;;;----------------------------------------------------------------------
(defn directed-face-labels
"adjust the face labels (P) to incorporate a globally-consistent
(but arbitrary) thread direction.
P is standard, with a north-to-east thread and a south-to-west thread.
Q has the north-to-east thread reversed.
R has the south-to-west thread reversed.
S has both reversed."
[config]
(let [config* (canonicalize-face-labels config)
threads (threads config*)]
(loop [faces (keys config*), config config*]
(if-let [[a b c d] (first faces)]
(let [segment-1 [#{a b} #{b c}]
segment-2 [#{c d} #{d a}]
thread-1 (first (filter (partial subthread-sign segment-1) threads))
thread-2 (first (filter (partial subthread-sign segment-2) threads))
sign-1 (subthread-sign segment-1 thread-1)
sign-2 (subthread-sign segment-2 thread-2)
]
(recur (rest faces)
(assoc config (first faces)
(cond (and (= 1 sign-1) (= 1 sign-2)) :P
(and (= -1 sign-1) (= 1 sign-2)) :Q
(and (= 1 sign-1) (= -1 sign-2)) :R
(and (= -1 sign-1) (= -1 sign-2)) :S
:else [:error thread-1 thread-2]
))))
config))))
(defn explode-components
"Explode a knotwork configuration into a list of its basic
skein-relation components."
([config]
(let [config (-> config
canonicalize-face-labels
directed-face-labels )]
(tree-decompose
(fn is-leaf? [config] (or (nil? config) (nil? (first (filter (comp #{:P :Q :R :S} val) config)))))
(fn make-leaf-fn [x]
(when x [(thread-info x)])
) ;; make-leaf-fn
(fn ramify [config]
(let [[face label]
(first (filter (comp #{:P :Q :R :S} val) config))
changed-label (fn [label] (assoc config face label))]
(cond (= :P label)
[nil (changed-label :U3) (changed-label :W1)]
(= :Q label)
[(changed-label :V1) (changed-label :X1) nil]
(= :R label)
[(changed-label :V3) (changed-label :X3) nil]
(= :S label)
[nil (changed-label :W2) (changed-label :U2)])))
(comp distinct concat) ;; make-tree-fn
config
))))
(def expose-components explode-components)
(defn unknot-faces
"Decompose the cube knotwork into a tree of simpler knotworks such that each face has at most one crossing.
Uses skein relations to make these three-part decompositions.
Face labels: U2, U3 (clockwise strands)
V1, V3 (parallel strands)
W1, W2 (anticlockwise strands)
P (standard double-crossed strands)
X1, X3 (X-shaped negative crossing)"
([config]
(let [config (-> config
canonicalize-face-labels
directed-face-labels )]
(tree-decompose
(fn is-leaf? [config]
(or (nil? config)
(nil? (first (filter (comp #{:P :Q :R :S} val) config)))))
(fn make-leaf-fn [x]
(when x (thread-info x)) ;;(knotwork-finish (thread-info x)))
) ;; make-leaf-fn
(fn ramify [config]
(let [[face label]
(first (filter (comp #{:P :Q :R :S} val) config))
changed-label (fn [label] (assoc config face label))]
(cond (= :P label)
[nil (changed-label :U3) (changed-label :W1)]
(= :Q label)
[(changed-label :V1) (changed-label :X1) nil]
(= :R label)
[(changed-label :V3) (changed-label :X3) nil]
(= :S label)
[nil (changed-label :W2) (changed-label :U2)])))
vector ;; make-tree-fn
config
))))
(comment :example
(map unknot-faces cube-knotwork-configurations)
(tree-map #(or (nil? %) (map? %)) ;;is-leaf?
identity ;; branches
vector ;; f
identity ;; g
(unknot-faces (first cube-knotwork-configurations))
)
;; SHOW THAT UNKNOT-FACES ELIMINATES ALL CROSSINGS
;; ON CUBE CONFIGURATIONS THAT HAVE ALL ZERO CROSSING NUMBERS.
;; (Incidentally, they all have one thread.)
(mapcat (comp (partial tree-map #(or (nil? %) (map? %))
identity ;; branches
concat ;; f
:crossings ;; g
)
unknot-faces)
(filter all-zero-crossings? cube-knotwork-configurations))
)
(defn **
([] 1)
([x] x)
([x e] (cond (zero? e) 1
(= 1 e) x
(even? e) (let [ret (** x (/ e 2))]
(* ret ret))
(odd? e) (* e (** x (dec e))))))
(defn quick-jones-polynomial [config]
(let [u 3,
t (* u u),
u⁻¹ (/ u),
t⁻¹ (/ t)
compute-unlink-value
(fn [num-components]
(let [m num-components]
(reduce * (repeat (dec m)
(/ (- (inc (* u u))) u)))))
solve-skein-relation
(fn [V+ V0 V-]
;; Solve for the element of the triple that's nil.
(cond (nil? V+)
(+ (* t t V-) (* u (dec t) V0))
(nil? V-)
(+ (* t⁻¹ t⁻¹ V+) (* u⁻¹ (dec t⁻¹) V0))
(nil? V0)
(/ (- (* t⁻¹ V+) (* t V-))
(- u u⁻¹))))
]
(->> config
;; (unknot-faces)
(tree-map
#(or (nil? %) (map? %)) ;; is-leaf
identity ;; branches
solve-skein-relation ;; f
(fn g [x]
(when x
(compute-unlink-value (count (segments-join (:segments x))))
));; g
)
)))
(comment :example
(map quick-jones-polynomial (identity (filter all-zero-crossings? cube-knotwork-configurations)))
)
(comment :example
"The final answer: none of these are the unknot.
(frequencies (map (comp (partial * 1.0) quick-jones-polynomial knotwork-finish thread-data directed-face-labels canonicalize-face-labels) cube-knotwork-configurations)))
(def custom-cube-1
"A cube with two rubber bands wrapped perpendicularly around it."
{:segments (map vec (permutation-from-cycles [#{1 2} #{3 4} #{7 8} #{5 6}]
[#{1 4} #{2 3} #{6 7} #{5 8}]))
:crossings
(list
{:over [#{1 2} #{3 4}] :under [#{1 4} #{2 3}]}
{:over [#{7 8} #{5 6}], :under [#{6 7} #{5 8}]}
)
})
(def custom-cube-2
"A cube with two inseparably linked rubber bands wrapped perpendicularly around it."
{:segments (map vec (permutation-from-cycles [#{1 2} #{3 4} #{7 8} #{5 6}]
[#{1 4} #{2 3} #{6 7} #{5 8}]))
:crossings
(list
{:over [#{1 2} #{3 4}] :under [#{1 4} #{2 3}]}
{:under [#{7 8} #{5 6}], :over [#{6 7} #{5 8}]}
)
})
(def custom-cube-3
"A left-hand trefoil knot embedded on a cube."
{:segments (map vec (partition 2 1
(list #{1 2} #{3 4} #{3 7} #{2 6}
#{1 5} #{1 4} #{2 3} #{6 7}
#{5 6} #{1 2}))),
:crossings (list {:under [#{1 2} #{3 4}], :over [#{1 4} #{2 3}]}
{:over [#{3 7} #{2 6}], :under [#{2 3} #{6 7}]}
{:under [#{2 6} #{1 5}], :over [#{5 6} #{1 2}]})})
(comment :example
(quick-jones-polynomial (knotwork-finish custom-cube-3))
;; => 737/6561
;; cf. https://mathworld.wolfram.com/JonesPolynomial.html
)
(def looped-cubes
(distinct (filter (comp not empty? reidemeister-1-crossings) (mapcat expose-components cube-knotwork-configurations))
))
;; (def looped-cubes-2
;; (distinct (filter (comp not empty? reidemeister-2-crossings) (mapcat expose-components cube-knotwork-configurations))
;; ))
(defn uncross-faces
"Use the skein relations to detangle the knotwork so that each face has at most one crossing.
Face labels: U2, U3 (clockwise strands)
V1, V3 (parallel strands)
W1, W2 (anticlockwise strands)
P (standard double-crossed strands)
X1, X3 (X-shaped negative crossing)
The two-argument functions is private; used internally.
"
([threads directed-config]
(let [config directed-config
recur* (partial uncross-faces threads)
solve-skein-relation identity ;; second identity
finish-detangling identity ;; (comp knotwork-decompose thread-info) ;; (comp reidemeister-detangle directed-threads-with-crossings) ;;identity
]
(if-let
[[face label]
(first (filter (comp #{:P :Q :R :S} val) config))]
(let [changed-label (fn [label] (assoc config face label))]
(solve-skein-relation
(cond (= :P label)
[nil (recur* (changed-label :U3)) (recur* (changed-label :W1))]
(= :Q label)
[(recur* (changed-label :V1)) (recur* (changed-label :X1)) nil]
(= :R label)
[(recur* (changed-label :V3)) (recur* (changed-label :X3)) nil]
(= :S label)
[nil (recur* (changed-label :W2)) (recur* (changed-label :U2))])))
(finish-detangling config)
)))
([config]
(let [config* (canonicalize-face-labels config)
segments (thread-segments config*)
threads (threads config*)
config* (directed-face-labels config*)
]
(uncross-faces threads config*))))
;; ;;;;----------------------------------------------------------------------
;; ;;;;; --------------------------- SKEIN RELATIONS II:
;; ;;;;; --------------------------- SIMPLIFY THE STRAND UNTIL IT'S UNLINKED.
;; ;;;;----------------------------------------------------------------------
;; ;
;; ;
;; ;
;; ;(defn knotwork-decompose
;; ; "Use the skein relations to decompose this knotwork into a tree of simpler
;; ; knotworks, with unlinks at the leaves."
;; ; [thread-info]
;; ;
;; ; (if (empty? (:crossings thread-info))
;; ; thread-info))
;; ;
;; ;
;; ;
;; ; ;;; Applying a skein relation requires knowing the crossing type.
;; ; ;;; Knowing the crossing type requires knowing the clockwise orientation of vertices.
;; ; ;;; Not sure how to compute that given these abstract vertices.
;; ;
;; ;
;; ;
;; ;
;; ; (defn jones-polynomial [thread-info]
;; ; (let [t -1
;; ; unlink (fn [num-components] num-components)]
;; ;
;; ; (cond (empty? (:crossings thread-info)) ;; UNLINK
;; ; (let [num-components (count (segments-join (:segments thread-info)))]
;; ; (unlink num-components))
;; ;
;; ; (not (empty? (reidemeister-1-moves thread-info)))
;; ; (recur (reduce apply-reidemeister-1
;; ; thread-info
;; ; (reidemeister-1-moves thread-info)))
;; ;
;; ; (not (empty? (reidemeister-2-moves thread-info)))
;; ; (recur (reduce apply-reidemeister-2
;; ; thread-info
;; ; (reidemeister-2-moves thread-info)))
;; )
;; ;
;; ;
;; ;
;; ;(defn directed-threads-with-crossings
;; ; "Given a cube configuration with directed face labels (V1, V2, etc.),
;; ; return a map listing all :segments and :crossings in the knotwork."
;; ; [directed-config]
;; ; ;; TODO: Confirm that the segments have a coherent global direction,
;; ; ;; otherwise adjust the polarity of the crossings.
;; ; (apply merge-with concat
;; ; (map (fn [[face label]]
;; ; (substitute (zipmap [:a :b :c :d] face) (get face-labels label)))
;; ; directed-config)))
;; (defn reidemeister-1-segment
;; "Return the subthread that comprises the extraneous reidemeister-1 loop."
;; [thread-data [orient-1 crossing-1] [orient-2 crossing-2]]
;; (let [segment-1 (seq (orient-1 crossing-1))
;; segment-2 (seq (orient-2 crossing-2))
;; thread (butlast (first (segments-join (:segments thread-data))))
;; thread (take (count thread) (iterate cycle-1 thread))
;; thread (first (filter (comp (partial = segment-1) (partial take 2)) thread))
;; thread (cyclic thread)
;; ]
;; (take
;; (inc (count (take-while (partial not= (second segment-2)) thread)))
;; thread)
;; ))
;; (defn reidemeister-1-excise
;; "Remove the subthread that comprises the extraneous reidemeister-1 loop,
;; delete the related crossing, and rebuild the connection as a straight segment."
;; [thread-data {orient-1 :type, crossing :crossing} {orient-2 :type, crossing :crossing}]
;; (let [subthread (reidemeister-1-segment thread-data [orient-1 crossing] [orient-2 crossing])]
;; (-> thread-data
;; (alter :segments
;; (partial remove (set (map vec (partition 2 1 subthread)))))
;; (alter :segments
;; #(conj % [(first (orient-1 crossing)) (second (orient-2 crossing))]))
;; (alter :crossings
;; (partial remove (partial = crossing))))))
;; (defn reidemeister-detangle
;; "Apply all three reidemeister moves to simplify the knot."
;; [thread-data]
;; ;;(println (reidemeister-1-crossings (crossing-chain thread-data)))
;; (->> thread-data
;; (iterate
;; (fn [thread-data]
;; (reduce (fn [thread-data reid]
;; (apply reidemeister-1-excise thread-data reid))
;; thread-data
;; (reidemeister-1-crossings (crossing-chain thread-data)))))
;; (partition 2 1)
;; (drop-while (fn [[x y]] (not= x y)))
;; (first)
;; (last))
;; )
;; (defn reidemeister-detangle
;; [thread-data]
;; (reidemeister-2-crossings (crossing-chain thread-data))
;; )
;; (let [config (first cube-knotwork-configurations)
;; thread-data (directed-threads-with-crossings (uncross-faces config))
;; chain (crossing-chain thread-data)
;; ;;info (reidemeister-1-crossings chain)
;; ;;reid (first info)
;; ]
;; (uncross-faces config)
;; )
;; (let [config (first cube-knotwork-configurations)
;; thread-data (directed-threads-with-crossings (uncross-faces config))
;; chain (crossing-chain thread-data)
;; ;;info (reidemeister-1-crossings chain)
;; ;;reid (first info)
;; ]
;; ;;(reidemeister-1-segment thread-data (first reid) (second reid))
;; ;;(reidemeister-1-excise thread-data (first reid) (second reid))
;; (reduce (fn [thread-data reid] (apply reidemeister-1-excise thread-data reid))
;; thread-data
;; (reidemeister-1-crossings chain))
;; )