# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1579374224 18000
# Node ID 892a16d8007efee480339bc34081cc2283201d2c
# Parent  72cd66a36853d24c4e73c73be9de9cbd3e4d3845
TRIE

diff -r 72cd66a36853 -r 892a16d8007e .hgignore
--- a/.hgignore	Sun Dec 22 13:21:30 2019 -0500
+++ b/.hgignore	Sat Jan 18 14:03:44 2020 -0500
@@ -2,4 +2,4 @@
 
 scratch.lisp
 lisp.prof
-digraph.png
+*.png
diff -r 72cd66a36853 -r 892a16d8007e src/problems/rear.lisp
--- a/src/problems/rear.lisp	Sun Dec 22 13:21:30 2019 -0500
+++ b/src/problems/rear.lisp	Sat Jan 18 14:03:44 2020 -0500
@@ -52,15 +52,16 @@
     (dolist (r (reversals v :start start :end end))
       (enqueue (cons n r) remaining))))
 
-(define-problem rear (data string)
-    *input-rear*
-    *output-rear*
-  (let ((pairs (-<> data
-                 (str:split (format nil "~2%") <>)
-                 (mapcar (curry #'str:split #\newline) <>)
-                 (mapcar (curry #'mapcar #'read-all-from-string) <>)
-                 (mapcar (curry #'mapcar (rcurry #'coerce 'vector)) <>))))
-    (iterate (for (from to) :in pairs)
-             (collect (time (reversals-required from to))))))
+;; todo: finish this one
+;; (define-problem rear (data string)
+;;     *input-rear*
+;;     *output-rear*
+;;   (let ((pairs (-<> data
+;;                  (str:split (format nil "~2%") <>)
+;;                  (mapcar (curry #'str:split #\newline) <>)
+;;                  (mapcar (curry #'mapcar #'read-all-from-string) <>)
+;;                  (mapcar (curry #'mapcar (rcurry #'coerce 'vector)) <>))))
+;;     (iterate (for (from to) :in pairs)
+;;              (collect (time (reversals-required from to))))))
 
 
diff -r 72cd66a36853 -r 892a16d8007e src/problems/trie.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/problems/trie.lisp	Sat Jan 18 14:03:44 2020 -0500
@@ -0,0 +1,104 @@
+(in-package :rosalind)
+
+(defparameter *input-trie*
+  "ATAGA
+ATC
+GAT")
+
+(defparameter *output-trie*
+  "1 2 A
+2 3 T
+3 4 A
+4 5 G
+5 6 A
+3 7 C
+1 8 G
+8 9 A
+9 10 T")
+
+
+;;;; Data Structure -----------------------------------------------------------
+(defstruct trie-node terminal children)
+
+(defun make-trie (strings)
+  (recursively ((strings strings))
+    (let ((terminal (find-if #'string-empty-p strings))
+          (strings (remove-if #'string-empty-p strings)))
+      (make-trie-node
+        :terminal (if terminal t nil)
+        :children (iterate
+                    (for (ch kids) :in-hashtable (group-by #'first-char strings))
+                    (collect-hash (ch (recur (mapcar (lambda (s) (subseq s 1))
+                                                     kids)))))))))
+
+(defun trie-child (trie character)
+  (gethash character (trie-node-children trie)))
+
+(defun trie-contains-p (trie string)
+  (iterate
+    (for ch :in-string string)
+    (setf trie (trie-child trie ch))
+    (when (null trie)
+      (return nil))
+    (finally (return (trie-node-terminal trie)))))
+
+
+;;;; Graphviz -----------------------------------------------------------------
+(defmethod cl-dot:graph-object-node ((graph (eql 'trie)) (node trie-node))
+  (make-instance 'cl-dot:node
+    :attributes (if (trie-node-terminal node)
+                  '(:shape :star :width 0.3 :height 0.3 :label "" :style :filled :fillcolor "#FF66CC")
+                  '(:shape :circle :width 0.2 :height 0.2 :label ""))))
+
+(defmethod cl-dot:graph-object-points-to ((graph (eql 'trie)) (node trie-node))
+  (iterate
+    (for (ch child) :in-hashtable (trie-node-children node))
+    (collect (make-instance 'cl-dot:attributed
+               :object child
+               :attributes `(:label ,(format nil " ~C " ch))))))
+
+(defun dot-graph (graph-type root &key (rankdir :lr))
+  (cl-dot:dot-graph
+    (cl-dot:generate-graph-from-roots
+      graph-type (list root)
+      `(:rankdir ,(string-upcase rankdir)))
+    "out.png" :format :png))
+
+
+;;;; Problem ------------------------------------------------------------------
+(defun trie-adjacency-list (root)
+  (gathering
+    (let ((i 0)
+          (numbers (make-hash-table)))
+      (flet ((n (node)
+               (alexandria:ensure-gethash node numbers (incf i))))
+        (recursively ((node root))
+          (iterate
+            (for (ch child) :in-hashtable (trie-node-children node))
+            (gather (list (n node) (n child) ch))
+            (recur child)))))))
+
+(define-problem trie (data stream)
+    *input-trie*
+    *output-trie*
+  (let* ((strings (read-lines data))
+         (trie (make-trie strings)))
+    ;; (dot-graph 'trie trie :rankdir :tb)
+    (format nil "~{~{~A~^ ~}~^~%~}" (trie-adjacency-list trie))))
+
+
+#; Scratch --------------------------------------------------------------------
+
+(problem-trie)
+
+(problem-trie
+  "apple
+apropos
+banana
+bandana
+orange")
+
+(problem-trie
+  "art
+artificial
+artistic")
diff -r 72cd66a36853 -r 892a16d8007e src/utils.lisp
--- a/src/utils.lisp	Sun Dec 22 13:21:30 2019 -0500
+++ b/src/utils.lisp	Sat Jan 18 14:03:44 2020 -0500
@@ -116,6 +116,15 @@
     result))
 
 
+;;;; Strings ------------------------------------------------------------------
+(defun string-empty-p (string)
+  (zerop (length string)))
+
+(defun first-char (string)
+  (if (string-empty-p string)
+    nil
+    (char string 0)))
+
 
 ;;;; Math ---------------------------------------------------------------------
 (defmacro do-sum ((var from to) &body body)
@@ -224,6 +233,13 @@
        (setf ,result ,form))))
 
 
+;;;; Readers ------------------------------------------------------------------
+(defun read-lines (stream)
+  "Read all lines from `stream` and return them as a fresh list of strings."
+  (iterate (for line :in-stream stream :using #'read-line)
+           (collect line)))
+
+
 ;;;; Buffers ------------------------------------------------------------------
 (defun make-buffer (&key initial-contents
                          (element-type t)