Merge pull request #71 from chuan6/enriched-toc

Enriched toc

generator/src/generator/core.clj

@@ -86,6 +86,7 @@
             (let [[items rests] (its/read-items cs)]
               (recur rests (into ts (-> items
                                         its/parse
+                                        pt/create
                                         (pt/update-leaves :id genid)
                                         flatten
                                         its/second-pass))))
@@ -388,7 +389,7 @@
        ;; (clojure.pprint/pprint r)
        ;; (println "------------------------")
        (t/is (= src (str/join (map its/str-token (flatten r)))))))
-   (let [r (its/parse (items (seq "本法第三十九条和第四十条第一项、第二项")))]
+   (let [r (pt/create (its/parse (items (seq "本法第三十九条和第四十条第一项、第二项"))))]
      (t/is
       (= '({:token :法 :nth :this :text "本法"}
            ({:token :条 :nth 39 :text "三十九" :第? true :unit? true :id "条39"}
@@ -399,7 +400,7 @@
               {:token :separator :text "、"})
              ({:token :项 :nth 2 :text "二" :第? true :unit? true :id "条40款1项2"}))))
          (pt/update-leaves r :id (partial id/generate {})))))
-   (let [r (its/parse (items (seq "本规定第十、十八、二十六、二十七条")))]
+   (let [r (pt/create (its/parse (items (seq "本规定第十、十八、二十六、二十七条"))))]
      (t/is
       (= '({:token :规定 :nth :this :text "本规定"}
            ({:token :条 :nth 10 :text "十" :第? true :unit? false :id "条10"}

generator/src/generator/id.clj

@@ -79,12 +79,14 @@
                 (f {} [{:token :法 :nth :this}
                        {:token :章 :nth 2}
                        {:token :节 :nth 1}])))))}
-  ([context tv]
-   (let [t (:token (peek tv))]
-     (when (contains? templates t)
-       (generate context
-                 (filterv (comp not its/item-types-2 :token) tv)
-                 t))))
+  ([context ts]
+   (let [ty (:token (last ts))]
+     (when (contains? templates ty)
+       (let [selected-ts (filter (comp not
+                                       its/item-types-2
+                                       :token)
+                                 ts)]
+         (generate context (vec selected-ts) ty)))))
 
   ([context tv expect]
    (let [interpret-nth (partial interpret-nth-with context)]

generator/src/generator/parse_tree.clj

@@ -26,7 +26,10 @@
 
 (def ^:private branch list)
 
-(def node-val (comp first z/node))
+(defn node-val [loc]
+  (let [x (z/node loc)]
+    (cond-> x
+      (seq? x) first)))
 
 (defn subtrees [loc]
   (->> loc
@@ -131,14 +134,50 @@
                   (rest rxs))))))))
 
 (defn update-leaves
-  ([tree k f] (update-leaves tree [] k f))
-  ([[v & children] path k f]
-   (let [sep-token? #(= (:token %) :separator)
-         path' (conj path v)]
-     (if (or (empty? children)
-             (every? sep-token? children))
-       (cons (assoc v k (f path')) children)
-       (cons v (map #(if (sep-token? %)
-                       %
-                       (update-leaves % path' k f))
-                    children))))))
+  {:test
+   #(let [f update-leaves
+          t1 (create (linear-to-tree () doc-hierachy))
+          t2 (create (nth examples 1))
+          pf count
+          k  :depth]
+      (tt/comprehend-tests
+       (t/is (= '({:depth 1}) (f t1 k pf)))
+       (t/is (= '({:token :法}
+                  ({:token :条}
+                   {:token :separator}
+                   ({:token :款 :nth 1}
+                    ({:token :项 :depth 4}))))
+                (f t2 k pf)))))}
+  [loc k f]
+  (letfn [(sep-token? [t]
+            (and (map? t) (= (:token t) :separator)))
+          (leaf? [loc]
+            (or (not (z/branch? loc))
+                (or (empty? (z/children loc))
+                    (and (every? map? (z/children loc))
+                         (every? sep-token? (z/children loc))))))
+          (ret-v [f loc]
+            (f (conj (vec (map first (z/path loc)))
+                     (node-val loc))))]
+    (if (z/end? loc)
+      (z/root loc)
+      (cond
+        (sep-token? (z/node loc))
+        (recur (z/next loc) k f)
+
+        (nil? (z/node loc))
+        (recur (z/next loc) k f)
+
+        (not (z/branch? loc))
+        (recur (z/next
+                (z/edit loc #(assoc % k (ret-v f loc)))) k f)
+
+        (or (empty? (z/children loc))
+            (every? sep-token? (z/children loc)))
+        (recur (z/next
+                (z/edit loc #(cons (assoc (first %) k (ret-v f loc))
+                                   (z/children loc))))
+               k f)
+
+        :else
+        (recur (z/next loc) k f)))))

generator/src/generator/toc.clj

@@ -7,67 +7,83 @@
             [generator.parse-tree :as pt]
             [generator.test :as tt]))
 
-(defn outline-html [ts]
-  (letfn [(max-hier [hval ts]
-            (apply max (remove nil? (map (pt/hierachy-fn hval) ts))))
-          (rise-ts [hval ts]
-            (pt/linear-to-tree
-             (cons {:token :pseudo-root} ts)
-             (pt/hierachy-fn
-              (merge hval {:序言 (max-hier hval ts)
-                           :pseudo-root (inc (apply max (vals hval)))}))))
-          (li [t]
+(defn outline-html [h]
+  (letfn [(li [t]
             (let [hash   (str "#" (id/entry-id (:context t) (:token t)))
                   elmt-a [:a {:href hash} (:text t)]]
               [:li
                [:div {:class "li-head"}
                 elmt-a
-                (when-let [ith (:from (:entrys-range t))]
-                  [:span (str "条" ith)])]]))
+                (when-let [r (:entries-range t)]
+                  (let [a (int (:from r))
+                        b (int (:to r))]
+                    [:span (str "条" a
+                                (when (not= a b) (str "-" b)))]))]]))
           (to-html [ot]
             (let [t (pt/node-val ot)
                   r (when (pt/internal-node? ot)
                       [:ul (for [li (pt/subtrees ot)]
                              (to-html li))])]
               (cond->> r
                 (seq (:text t)) (conj (li t)))))]
-    (to-html
-     (pt/create
-      (pt/update-leaves
-       (rise-ts {:节 1 :章 2 :则 3 :编 3} ts)
-       :entrys-range (fn [path] (let [x (peek path)]
-                                  {:from ((comp int (fnil inc 0))
-                                          (:条 (:context x)))})))))))
+    (to-html (pt/create h))))
 
 (defn generate-table-of-contents
   {:test
    #(let [f generate-table-of-contents
           tls (ln/draw-skeleton ["前言" "第一章" "a"
-                              "第二章" "b"
-                              "第三章" "第一节" "……"])
-          titles (ln/draw-skeleton ["第一章"
-                                 "第二章"
-                                 "第三章" "第一节"])]
+                                 "第二章" "b"
+                                 "第三章" "第一节" "第二条……"])]
       (tt/comprehend-tests
        (t/is (= [() nil] (f ())))
        (t/is (= [["前言"] nil]
                 (->> [(map :text prelude) r]
                      (let [[prelude r] (f (take 1 tls))]))))
        (t/is (= {:token :table-of-contents
                  :text "目录"
-                 :list titles
+                 :list '({:token :pseudo-root}
+                         ({:token :章, :nth 1, :text "第一章"})
+                         ({:token :章, :nth 2, :text "第二章"})
+                         ({:token :章, :nth 3, :text "第三章"}
+                          {:token :节, :nth 1, :text "第一节"
+                           :entries-range {:from 2 :to 2}}))
                  :not-in-original-text true}
                 (second (f tls))))))}
   [tls]
-  (let [[prelude tls'] (split-with #(= (:token %)
-                                       :to-be-recognized) tls)
-        tys #{:序言 :编 :则 :章 :节}
-        titles (filter #(tys (:token %)) tls')]
-    [prelude (when (seq titles)
-               {:token :table-of-contents
-                :text "目录"
-                :list titles
-                :not-in-original-text true})]))
+  (letfn [(max-hier [hval ts]
+            (apply max (remove nil? (map (pt/hierachy-fn hval) ts))))
+          (rise-ts [hval ts]
+            (pt/linear-to-tree
+             (cons {:token :pseudo-root} ts)
+             (pt/hierachy-fn
+              ;;hier val of :序言 is determined dynamically
+              (merge hval {:序言 (max-hier hval ts)
+                           :pseudo-root (inc (apply max (vals hval)))}))))
+          (digest-条s-in-hier [h]
+            (let [node first
+                  v (node h)
+                  children (rest h)
+                  flag #(= (:token %) :条)
+                  digest (fn [es] {:from (:nth (first es))
+                                   :to (:nth (last es))})]
+              (if (empty? children)
+                h
+                (let [cvs (map node children)]
+                  (if (every? flag cvs)
+                    (assoc v :entries-range (digest cvs))
+                    (cons v (map digest-条s-in-hier children)))))))]
+   (let [[prelude tls-initial]
+         (split-with #(= (:token %) :to-be-recognized) tls)
+
+         tls-prepare
+         (filter #(#{:序言 :编 :则 :章 :节 :条} (:token %)) tls-initial)]
+     [prelude (when (seq (remove #(= (:token %) :条) tls-prepare))
+                {:token :table-of-contents
+                 :text "目录"
+                 :list (digest-条s-in-hier
+                        (rise-ts {:条 0 :节 1 :章 2 :则 3 :编 3}
+                                 tls-prepare))
+                 :not-in-original-text true})])))
 
 (def table-of-contents-sentinel #"目\s*录")
 (defn table-of-contents