family-tree.lisp 4.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111
  1. ;;;; family-tree.lisp
  2. (in-package #:genie)
  3. ;;; "family-tree" goes here. Hacks and glory await!
  4. ;;; Generate nodes for people
  5. (defun generate-person-node (person-id)
  6. (let ((person (get-person person-id))
  7. (birth (get-birth person-id))
  8. (death (get-death person-id)))
  9. (format nil "person_~a [label = \"~a\", color = ~a, shape = rectangle];"
  10. person-id
  11. (format nil "~a\\\n~a — ~a"
  12. (:/person-name person)
  13. (:/birth-date birth)
  14. (if (not (null death))
  15. (:/death-date death)
  16. "Living"))
  17. (if (string= (:/gender person) "M") "blue" "pink"))))
  18. ;;; Generate edges between people
  19. (defun generate-person-edges (person-id)
  20. (let* ((birth (get-birth person-id))
  21. (mother (:/mother birth))
  22. (father (:/father birth)))
  23. (cond
  24. ((and (= 0 father)
  25. (= 0 mother))
  26. "")
  27. ((= 0 father)
  28. (format nil "person_~a -> person_~a;" mother person-id))
  29. ((= 0 mother)
  30. (format nil "person_~a -> person_~a;" father person-id))
  31. (t
  32. (let ((marriage (get-marriage father mother)))
  33. (if (null marriage)
  34. (format nil "{person_~a, person_~a} -> person_~a;"
  35. mother
  36. father
  37. person-id)
  38. (format nil "marriage_~a -> person_~a;"
  39. (:/marriage-id marriage)
  40. person-id)))))))
  41. ;;; Generate nodes for weddings
  42. ;; (defun generate-marriage-node (marriage-id)
  43. ;; (let ((marriage (first (select :marriages (where (equal :/marriage-id
  44. ;; marriage-id)))))
  45. ;; (divorce (first (select :divorces (where (equal :/marriage marriage-id))))))
  46. ;; (format nil "marriage_~a [label = \"Married ~a — ~a\", shape = invtrapezium];"
  47. ;; marriage-id
  48. ;; (:/wedding-date marriage)
  49. ;; (if (not (null divorce))
  50. ;; (if (string= "0" (:/end-date marriage))
  51. ;; "Present"
  52. ;; (:/end-date marriage))
  53. ;; (format nil "Div. ~a" (:/divorce-date divorce))))))
  54. (defun generate-marriage-node (marriage-id)
  55. (let* ((marriage (get-marriage-id marriage-id))
  56. (start-date (:/wedding-date marriage))
  57. (end-date (:/end-date marriage))
  58. (divorce (get-divorce marriage-id)))
  59. (format nil "marriage_~a [label = \"Married ~a — ~a\", shape = none];"
  60. marriage-id
  61. start-date
  62. (if (null divorce)
  63. (if (string= "0" end-date)
  64. "Present"
  65. (:/end-date marriage))
  66. (format nil "Div. ~a" (:/divorce-date divorce))))))
  67. ;;; Generate edges for weddings
  68. (defun generate-marriage-edges (marriage-id)
  69. (let* ((marriage (first (select :marriages
  70. (where (equal :/marriage-id marriage-id)))))
  71. (husband-id (:/husband marriage))
  72. (wife-id (:/wife marriage)))
  73. (format nil "{person_~a, person_~a} -> marriage_~a;"
  74. husband-id
  75. wife-id
  76. marriage-id)))
  77. ;;; Generate Family Tree
  78. (defun generate-graph (file-name)
  79. (let ((people (iter (for i from 1 to (length (select :people)))
  80. (collect (generate-person-node i))))
  81. (birth-edges (remove-if (lambda (edge)
  82. (string= edge ""))
  83. (iter (for i from 1 to (length (select :people)))
  84. (collect (generate-person-edges i)))))
  85. (weddings (iter (for i from 1 to (length (select :marriages)))
  86. (collect (generate-marriage-node i))))
  87. (wedding-edges (iter (for i from 1 to (length (select :marriages)))
  88. (collect (generate-marriage-edges i)))))
  89. (with-open-file (out file-name
  90. :direction :output
  91. :if-exists :overwrite
  92. :if-does-not-exist :create)
  93. (format out
  94. "digraph {
  95. ~{ ~a~%~}
  96. ~{ ~a~%~}
  97. ~{ ~a~%~}
  98. ~{ ~a~%~}
  99. }"
  100. people
  101. weddings
  102. wedding-edges
  103. birth-edges))))