Initial commit

.gitignore

@@ -0,0 +1,10 @@
+.*
+!.gitignore
+*.aux
+*.bcf
+*.log
+*.out
+*.run.xml
+auto/*
+*~
+\#*\#

README.txt

@@ -0,0 +1 @@
+This is the stub README.txt for the "genie" project.

database.lisp

@@ -0,0 +1,121 @@
+;;;; database.lisp
+
+(in-package #:genie)
+
+;;; "database" goes here. Hacks and glory await!
+(defmacro constrain-values (&rest values)
+  `(lambda (object)
+     (the boolean
+          (member object (list ,@values)))))
+
+(defmacro in-table-column (table column)
+  `(lambda (object)
+     (let ((possible-values (iter
+                              (for row in (select ,table))
+                              (collect (,column row)))))
+       (the boolean (member object possible-values)))))
+
+(defmacro unique-in-column (table column type)
+  `(lambda (object)
+     (if (typep object ',type)
+         (let ((possible-values (iter
+                                  (for row in (select ,table))
+                                  (collect (,column row)))))
+           (not (the boolean (member object possible-values)))))))
+
+(defun generate-table-id (table)
+  (declare (keyword table))
+  (1+ (length (select table))))
+
+;;; The Person table
+(defattributes
+  :/person-id (unique-in-column :people :/person-id integer)
+  :/person-name #'stringp
+  :/gender (constrain-values "M" "F"))
+
+;;; The Births table
+(defattributes
+  :/birth-id (unique-in-column :births :/birth-id integer)
+  :/birth-person (in-table-column :people :/person-id)
+  :/birth-date #'stringp
+  :/father (lambda (object)
+             (or (= 0 object)
+                (funcall (in-table-column :people :/person-id) object)))
+  :/mother (lambda (object)
+             (or (= 0 object)
+                (funcall (in-table-column :people :/person-id) object))))
+
+;;; The Deaths table
+(defattributes
+  :/death-id (unique-in-column :deaths :/death-id integer)
+  :/death-person (in-table-column :people :/person-id)
+  :/death-date #'stringp)
+
+
+;;; The Marriages table
+(defattributes
+  :/marriage-id (unique-in-column :marriages :/marriage-id integer)
+  :/husband (in-table-column :people :/person-id)
+  :/wife (in-table-column :people :/person-id)
+  :/wedding-date #'stringp
+  :/end-date #'stringp)
+
+
+;;; The Divorces table
+(defattributes
+  :/divorce-id (unique-in-column :divorces :/divorce-id integer)
+  :/marriage (in-table-column :marriages :/marriage-id)
+  :/divorce-date #'stringp)
+
+
+;;; insert person
+(defun new-person (name gender birth-date mother father)
+  (declare (string name)
+           (integer mother
+                    father))
+  (with-tx
+    (let ((person-id (generate-table-id :people))
+          (birth-id (generate-table-id :births)))
+      (insert :people
+              (list :/person-id person-id
+                    :/person-name name
+                    :/gender gender))
+      (insert :births
+              (list :/birth-id birth-id
+                    :/birth-person person-id
+                    :/birth-date birth-date
+                    :/mother mother
+                    :/father father))
+      (values person-id birth-id))))
+
+;;; insert death
+(defun new-death (person death-date)
+  (with-tx
+    (let ((death-id (generate-table-id :deaths)))
+      (insert :deaths
+              (list :/death-id death-id
+                    :/death-person person
+                    :/death-date death-date))
+      death-id)))
+
+;;; insert marriage
+(defun new-marriage (husband wife date end-date)
+  (with-tx
+    (let ((marriage-id (generate-table-id :marriages)))
+      (insert :marriages
+              (list :/marriage-id marriage-id
+                    :/husband husband
+                    :/wife wife
+                    :/wedding-date date
+                    :/end-date date))
+      marriage-id)))
+
+;;; insert divorce
+(defun new-divorce (marriage-id date)
+  (with-tx
+    (let ((divorce-id (generate-table-id :divorces)))
+      (insert :divorces
+              (list :/divorce-id divorce-id
+                    :/marriage marriage-id
+                    :/divorce-date date))
+      divorce-id)))

family-tree.lisp

@@ -0,0 +1,130 @@
+;;;; family-tree.lisp
+
+(in-package #:genie)
+
+;;; "family-tree" goes here. Hacks and glory await!
+
+;;; Generate nodes for people
+(defun generate-person-node (person-id)
+  (let ((person (first (select :people (where (equal :/person-id person-id)))))
+        (birth (first (select :births (where (equal :/birth-person person-id)))))
+        (death (first (select :deaths (where (equal :/death-person person-id))))))
+    (format nil "person_~a [label = \"~a\", color = ~a, shape = rectangle];"
+            person-id
+            (format nil "~a\\\n~a — ~a"
+                    (:/person-name person)
+                    (:/birth-date birth)
+                    (if (not (null death))
+                        (:/death-date death)
+                        "Living"))
+            (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)))))
+         (mother (:/mother birth))
+         (father (:/father birth))
+         (marriage
+          (first (select :marriages
+                         (where (and (equal :/wife mother)
+                                   (equal :/husband father)))))))
+    (cond
+      ((= 0 (:/father birth))
+       )
+      ((= 0 (:/mother birth))
+       (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)))))
+
+(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 = invtrapeseum];"
+            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))))))
+
+;;; Generate edges for weddings
+(defun generate-marriage-edges (marriage-id)
+  (let* ((marriage (first (select :marriages
+                                  (where (equal :/marriage-id marriage-id)))))
+         (husband-id (:/husband marriage))
+         (wife-id (:/wife marriage)))
+    (format nil "{person_~a, person_~a} -> marriage_~a;"
+            husband-id
+            wife-id
+            marriage-id)))
+
+;; (defun generate-graph ()
+;;   ())

genie.asd

@@ -0,0 +1,27 @@
+;;;; genie.asd
+;;;;
+;;;; Copyright (c) 2015 Samuel Flint <swflint@lisp.technology>
+
+(asdf:defsystem #:genie
+  :description "Describe genie here"
+  :author "Samuel Flint <swflint@lisp.technology>"
+  :license "GNU GPLv3 or Later"
+  :depends-on (#:restas
+               #:3bmd
+               #:babel
+               #:cl-utilities
+               #:cl-who
+               #:esrap
+               #:html-template
+               #:ironclad
+               #:lass
+               #:parenscript
+               #:parse-number
+               #:lambdalite
+               #:iterate
+               #:archive)
+  :serial t
+  :components ((:file "package")
+               (:file "database")
+               (:file "family-tree")
+               (:file "genie")))

genie.lisp

@@ -0,0 +1,8 @@
+;;;; genie.lisp
+;;;;
+;;;; Copyright (c) 2015 Samuel Flint <swflint@lisp.technology>
+
+(in-package #:genie)
+
+;;; "genie" goes here. Hacks and glory await!
+

package.lisp

@@ -0,0 +1,30 @@
+;;;; package.lisp
+;;;;
+;;;; Copyright (c) 2015 Samuel Flint <swflint@lisp.technology>
+
+(defpackage #:config-parser
+  (:use :esrap
+        :cl)
+  (:import-from #:parse-number
+                #:parse-number)
+  (:export open-configuration-file))
+
+(restas:define-module #:genie
+  (:use #:cl
+        #:lambdalite
+        #:config-parser
+        #:restas
+        #:cl-who
+        #:iterate)
+  (:import-from #:ironclad
+                #:pbkdf2-hash-password
+                #:byte-array-to-hex-string
+                #:hex-string-to-byte-array)
+  (:import-from #:hunchentoot
+                #:post-parameter
+                #:start-session
+                #:session-value)
+  (:import-from #:html-template
+                #:create-template-printer)
+  (:import-from #:lass
+                #:compile-and-write))

test.dot

@@ -0,0 +1,22 @@
+digraph {
+        grandpa [label = "Fred Bar\n1938-01-01 — Living", color = blue, shape = rectangle];
+        grandma [label = "Henrietta Bar", color = pink, shape = rectangle];
+        dad [label = "John Bar", color = blue, shape = rectangle];
+        mom;
+        child;
+        uncle;
+        marriagea;
+        marriageb;
+
+        grandpa -> marriagea;
+        grandma -> marriagea;
+
+        marriagea -> dad;
+        //-> marriageb;
+        //mom -> marriageb;
+
+        marriagea -> uncle;
+
+        //marriageb -> child;
+        {mom, dad} -> child;
+}