Rewrote some things

family-tree.lisp

@@ -20,97 +20,53 @@
             (if (string= (:/gender person) "M") "blue" "pink"))))
 
 ;;; Generate edges between people
-;; (defun generate-person-edges (person-id)
-;;   (let ((birth (first (select :births (where (equal :/person person-id))))))
-;;     (if (or (= 0 (:/father birth))
-;;            (= 0 (:/mother birth)))
-;;         (if (= 0 (:/mother birth))
-;;             (format nil "person_~a -> person_~a;" (:/father birth) person-id)
-;;             (if (= 0 (:/father birth))
-;;                 (format nil "person_~a -> person_~a;" (:/mother birth) person-id)
-;;                 ""))
-;;         (let ((marriage
-;;                (first (select :marriages
-;;                               (where (and (equal :/wife (:/mother birth))
-;;                                         (equal :/husband (:/father birth))))))))
-;;           (if (not (null marriage))
-;;               (format nil "marriage_~a -> person_~a;"
-;;                       (:/marriage-id marriage)
-;;                       person-id)
-;;               (format nil "{person_~a, person_~a} -> person_~a"
-;;                       (:/mother birth)
-;;                       (:/father birth)
-;;                       person-id))))))
-
 (defun generate-person-edges (person-id)
-  (let* ((birth
-          (first (select :births (where (equal :/person person-id)))))
+  (let* ((birth (get-birth person-id))
          (mother (:/mother birth))
-         (father (:/father birth))
-         (marriage
-          (first (select :marriages
-                         (where (and (equal :/wife mother)
-                                   (equal :/husband father)))))))
+         (father (:/father birth)))
     (cond
-      ((= 0 (:/father birth))
-       )
-      ((= 0 (:/mother birth))
+      ((and (= 0 father)
+          (= 0 mother))
+       "")
+      ((= 0 father)
+       (format nil "person_~a -> person_~a;" mother person-id))
+      ((= 0 mother)
        (format nil "person_~a -> person_~a;" father person-id))
-      ((null marriage)
-       (format nil "{person_~a, person_~a} -> person_~a;"
-               mother
-               father
-               person-id))
       (t
-       (format nil "marriage_~a -> person_~a;"
-               (:/marriage-id marriage)
-               person-id)))))
+       (let ((marriage (get-marriage father mother)))
+         (if (null marriage)
+             (format nil "{person_~a, person_~a} -> person_~a;"
+                     mother
+                     father
+                     person-id)
+             (format nil "marriage_~a -> person_~a;"
+                     (:/marriage-id marriage)
+                     person-id)))))))
 
-(defun generate-person-edges (person-id)
-  (flet ((unlisted-father (birth-record)
-           (= 0 (:/father birth-record)))
-         (unlisted-mother (birth-record)
-           (= 0 (:/mother birth-record)))
-         (parent-married-status (birth-record)
-           (let* ((mother (:/mother birth-record))
-                  (father (:/father birth-record))
-                  (records (select :marriages))
-                  (record (first
-                           (remove-if (lambda (record)
-                                        (not (= (:/wife record) mother)))
-                                      (remove-if (lambda (record)
-                                                   (not (= (:/husband record) father)))
-                                                 records)))))
-             (values (not (null record)) (:/marriage-id record)))))
-    (let ((birth (first (select :births
-                                (where (equal :/birth-person person-id))))))
-      (cond
-        ((unlisted-father birth)
-         (format nil "person_~a -> person_~a;" (:/mother birth) person-id))
-        ((unlisted-mother birth)
-         (format nil "person_~a -> person_~a;" (:/father birth) person-id))
-        ((parent-married-status birth)
-         (multiple-value-bind (bool id)
-             (parent-married-status birth)
-           (declare (ignore bool))
-           (format nil "marriage_~a -> person_~a;"
-                   id
-                   person-id)))
-        ((not (parent-married-status birth))
-         (format nil "{person_~a, person_~a} -> person_~a;"
-                 (:/mother birth)
-                 (:/father birth)
-                 person-id))))))
 ;;; Generate nodes for weddings
+;; (defun generate-marriage-node (marriage-id)
+;;   (let ((marriage (first (select :marriages (where (equal :/marriage-id
+;;                                                           marriage-id)))))
+;;         (divorce (first (select :divorces (where (equal :/marriage marriage-id))))))
+;;     (format nil "marriage_~a [label = \"Married ~a — ~a\", shape = invtrapezium];"
+;;             marriage-id
+;;             (:/wedding-date marriage)
+;;             (if (not (null divorce))
+;;                 (if (string= "0" (:/end-date marriage))
+;;                     "Present"
+;;                     (:/end-date marriage))
+;;                 (format nil "Div. ~a" (:/divorce-date divorce))))))
+
 (defun generate-marriage-node (marriage-id)
-  (let ((marriage (first (select :marriages (where (equal :/marriage-id
-                                                          marriage-id)))))
-        (divorce (first (select :divorces (where (equal :/marriage marriage-id))))))
-    (format nil "marriage_~a [label = \"Married ~a — ~a\", shape = invtrapeseum];"
+  (let* ((marriage (get-marriage-id marriage-id))
+         (start-date (:/wedding-date marriage))
+         (end-date (:/end-date marriage))
+         (divorce (get-divorce marriage-id)))
+    (format nil "marriage_~a [label = \"Married ~a — ~a\", shape = invtrapezium];"
             marriage-id
-            (:/wedding-date marriage)
-            (if (not (null divorce))
-                (if (string= "0" (:/end-date marriage))
+            start-date
+            (if (null divorce)
+                (if (string= "0" end-date)
                     "Present"
                     (:/end-date marriage))
                 (format nil "Div. ~a" (:/divorce-date divorce))))))
@@ -126,5 +82,30 @@
             wife-id
             marriage-id)))
 
-;; (defun generate-graph ()
-;;   ())
+;;; Generate Family Tree
+(defun generate-graph (file-name)
+  (let ((people (iter (for i from 1 to (length (select :people)))
+                      (collect (generate-person-node i))))
+        (birth-edges (remove-if (lambda (edge)
+                                  (string= edge ""))
+                                (iter (for i from 1 to (length (select :people)))
+                                      (collect (generate-person-edges i)))))
+        (weddings (iter (for i from 1 to (length (select :marriages)))
+                        (collect (generate-marriage-node i))))
+        (wedding-edges (iter (for i from 1 to (length (select :marriages)))
+                             (collect (generate-marriage-edges i)))))
+    (with-open-file (out file-name
+                         :direction :output
+                         :if-exists :overwrite
+                         :if-does-not-exist :create)
+      (format out
+              "digraph {
+~{	~a~%~}
+~{	~a~%~}
+~{	~a~%~}
+~{	~a~%~}
+}"
+              people
+              weddings
+              wedding-edges
+              birth-edges))))

genie.asd

@@ -24,4 +24,6 @@
   :components ((:file "package")
                (:file "database")
                (:file "family-tree")
+               (:file "templates")
+               (:file "routes")
                (:file "genie")))

mainpage.httmpl

@@ -0,0 +1,45 @@
+<html>
+  <head>
+    <title><!-- TMPL_VAR title --></title>
+    <link rel='StyleSheet' href='/main.css' />
+    <script src='/main.js'></script>
+  </head>
+  <body>
+    <div class='nav'>
+      <ul>
+        <!-- TMPL_LOOP nav -->
+        <!-- TMPL_IF heading -->
+        <!-- TMPL_IF href -->
+        <h2><a href='<!-- TMPL_VAR href -->'><!-- TMPL_VAR heading --></a></h2>
+        <!-- TMPL_ELSE -->
+        <h2><!-- TMPL_VAR heading --></h2>
+        <!-- /TMPL_IF -->
+        <!-- TMPL_ELSE -->
+        <li><a href='<!-- TMPL_VAR href -->'><!-- TMPL_VAR title --></a></li>
+        <!-- /TMPL_IF -->
+        <!-- /TMPL_LOOP -->
+        <hr />
+        <form action='search'
+              method='post'>
+          <input type='text'
+                 name='terms' />
+          <input type='hidden'
+                 name='page'
+                 value='1' />
+          <input type='submit'
+                 value='Search' />
+        </form>
+        <li><a href='search/advanced'>Advanced Search</a></li>
+        <hr />
+        <li><a href='/'>Main</a></li>
+        <li><a href='/help'>Help</a></li>
+        <li><a href='/logout'>Logout</a></li>
+      </ul>
+    </div>
+    <div class='main-content'>
+      <h1><!-- TMPL_VAR title --></h1>
+
+      <!-- TMPL_VAR content -->
+    </div>
+  </body>
+</html>

routes.lisp

@@ -0,0 +1,52 @@
+;;;; routes.lisp
+
+(in-package #:genie)
+
+;;; "routes" goes here. Hacks and glory await!
+
+(defun generate-nav (main &optional sub)
+  (declare (ignorable main sub))
+  `((:heading "Add" :href ,(genurl 'add))
+    (:title "Person" :href ,(genurl 'add/person))
+    (:title "Death" :href ,(genurl 'add/death))
+    (:title "Marriage" :href ,(genurl 'add/marriage))
+    (:title "Divorce" :href ,(genurl 'add/divorce))
+    (:heading "Notes" :href ,(genurl 'notes))
+    (:title "Add" :href ,(genurl 'notes/add))
+    (:title "View" :href ,(genurl 'notes/view))
+    (:title "Edit" :href ,(genurl 'notes/edit))
+    (:heading "Records" :href ,(genurl 'records))
+    (:title "Add" :href ,(genurl 'records/add))
+    (:title "View" :href ,(genurl 'records/view))
+    (:heading "Reports" :href ,(genurl 'reports))
+    (:title "Add" :href ,(genurl 'reports/add))
+    (:title "View" :href ,(genurl 'reports/view))
+    (:title "Edit" :href ,(genurl 'reports/edit))
+    (:title "Generate" :href ,(genurl 'reports/generate))))
+
+(define-route main ("")
+  (main-page :nav (generate-nav :main)))
+
+(define-route add ("add"))
+(define-route add/person ("add/person"))
+(define-route add/marriage ("add/marriage"))
+(define-route add/divorce ("add/divorce"))
+(define-route add/death ("add/death"))
+
+(define-route notes ("notes"))
+(define-route notes/add ("notes/add"))
+(define-route notes/edit ("notes/edit"))
+(define-route notes/view ("notes/view"))
+
+(define-route records ("records"))
+(define-route records/add ("records/add"))
+(define-route records/view ("records/view"))
+
+(define-route reports ("reports"))
+(define-route reports/add ("reports/add"))
+(define-route reports/view ("reports/view"))
+(define-route reports/edit ("reports/edit"))
+(define-route reports/generate ("reports/generate"))
+
+(define-route search-page ("search"))
+(define-route search/advanced ("search/advanced"))

templates.lisp

@@ -0,0 +1,123 @@
+;;;; templates.lisp
+
+(in-package #:genie)
+
+;;; "templates" goes here. Hacks and glory await!
+
+(defmacro define-html-template (name input &optional docstring)
+  (let* ((old-name name)
+         (name (intern (string-upcase old-name)))
+         (docstring (if docstring
+                        docstring
+                        (format nil "Template caller for ~a, as ~a" old-name name)))
+         (input (merge-pathnames input (asdf:system-source-directory '#:museum-system))))
+    `(defun ,name (&rest args)
+       ,docstring
+       (with-output-to-string (*standard-output*)
+         (funcall (create-template-printer ,input) args)))))
+
+
+(defmacro generate-static (name filename type script)
+  (declare (string filename)
+           (symbol type)
+           (type (or string symbol) name))
+  (let* ((name (intern (string-upcase name)))
+         (type (getf (list :js "application/javascript"
+                           :javascript "application/javascript"
+                           :css "text/css")
+                     type)))
+    `(define-route ,name (,filename
+                          :content-type ,type)
+       ,script)))
+
+
+(defmacro define-css-page (name filename &rest body)
+  (let* ((name (intern (string-upcase filename)))
+         (css-chunks (map 'list #'compile-and-write body))
+         (css (format nil "~{~a~^~%~%~}" css-chunks)))
+    `(generate-static ,name
+                      ,filename
+                      :css
+                      ,css)))
+
+(defmacro define-js-page (name filename &rest script)
+  (let ((name (intern (string-upcase filename))))
+    `(generate-static ,name
+                      ,filename
+                      :javascript
+                      (ps ,@script))))
+
+(setq parenscript:*js-string-delimiter* #\")
+(setq html-template:*string-modifier* #'cl:identity)
+
+(define-css-page main.css "main.css"
+  (*
+   :margin 0
+   :padding 0
+   :font-family "Georgia, Palantino, Times, 'Times New Roman', sans-serif")
+  (body
+   :backgroud "#fff")
+  (a
+   :text-decoration "none")
+  ("a:link, a:visited"
+   :color "#f30")
+  ("a:hover"
+   :color "#f90")
+  (div.main-content
+   :position "absolute"
+   :top "40px"
+   :left "280px"
+   :width "500px"
+   (h1
+    :font-size "40px"
+    :font-weight "normal"
+    :line-height "43px"
+    :letter-spacing "-1px")
+   (div.results
+    :margin-top "20px"
+    (ul
+     :list-style-type "none")
+    (li
+     :font-size "18px"
+     :line-height "24px"
+     :margin-left "70px"))
+   (div.page-list
+    :text-align "center"
+    :float "bottom")
+   (dl
+    :margin-top "10px")
+   (dt
+    :font-size "18px"
+    :font-weight "bold")
+   (dd
+    :margin-left "20px"
+    :margin-bottom "15px"))
+  (div.nav
+   :position absolute
+   :top "40px"
+   :left "20px"
+   :width "200px"
+   :padding "20px 20px 0 0"
+   :border-right "1px solid #ccc"
+   :text-align "right"
+   (h2
+    :text-transform "uppercase"
+    :font-size "13px"
+    :color "#333"
+    :letter-spacing "1px"
+    :line-height "20px"
+    (a
+     :color "#333"))
+   (ul
+    :list-style-type "none"
+    :margin "20px 0")
+   (li
+    :font-size "14px"
+    :line-height "20 px")
+   (hr
+    :height "1px"
+    :color "#ccc"
+    :margin-top "5px"
+    :margin-bottom "5px")))
+
+(define-html-template main-page "mainpage.httmpl")