database.lisp 5.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195
  1. ;;;; database.lisp
  2. (in-package #:genie)
  3. ;;; "database" goes here. Hacks and glory await!
  4. (defmacro constrain-values (&rest values)
  5. `(lambda (object)
  6. (the boolean
  7. (member object (list ,@values)))))
  8. (defmacro in-table-column (table column)
  9. `(lambda (object)
  10. (let ((possible-values (iter
  11. (for row in (select ,table))
  12. (collect (,column row)))))
  13. (the boolean (member object possible-values)))))
  14. (defmacro ids-in-table-column (table column)
  15. `(lambda (object)
  16. (let ((possible-values (iter
  17. (for row in (select ,table))
  18. (collect (,column row)))))
  19. (and (listp object)
  20. (reduce #'and (map 'list ,(in-table-column table column)
  21. object))))))
  22. (defmacro unique-in-column (table column type)
  23. `(lambda (object)
  24. (if (typep object ',type)
  25. (let ((possible-values (iter
  26. (for row in (select ,table))
  27. (collect (,column row)))))
  28. (not (the boolean (member object possible-values)))))))
  29. (defun generate-table-id (table)
  30. (declare (keyword table))
  31. (1+ (length (select table))))
  32. ;;; The Person table
  33. (defattributes
  34. :/person-id (unique-in-column :people :/person-id integer)
  35. :/person-name #'stringp
  36. :/gender (constrain-values "M" "F"))
  37. ;;; The Births table
  38. (defattributes
  39. :/birth-id (unique-in-column :births :/birth-id integer)
  40. :/birth-person (in-table-column :people :/person-id)
  41. :/birth-date #'stringp
  42. :/father (lambda (object)
  43. (or (= 0 object)
  44. (funcall (in-table-column :people :/person-id) object)))
  45. :/mother (lambda (object)
  46. (or (= 0 object)
  47. (funcall (in-table-column :people :/person-id) object))))
  48. ;;; The Deaths table
  49. (defattributes
  50. :/death-id (unique-in-column :deaths :/death-id integer)
  51. :/death-person (in-table-column :people :/person-id)
  52. :/death-date #'stringp)
  53. ;;; The Marriages table
  54. (defattributes
  55. :/marriage-id (unique-in-column :marriages :/marriage-id integer)
  56. :/husband (in-table-column :people :/person-id)
  57. :/wife (in-table-column :people :/person-id)
  58. :/wedding-date #'stringp
  59. :/end-date #'stringp)
  60. ;;; The Divorces table
  61. (defattributes
  62. :/divorce-id (unique-in-column :divorces :/divorce-id integer)
  63. :/marriage (in-table-column :marriages :/marriage-id)
  64. :/divorce-date #'stringp)
  65. ;;; Common to the notes/records
  66. (defattributes
  67. :/person (in-table-column :people :/person-id)
  68. :/birth (in-table-column :births :/birth-id)
  69. :/death (in-table-column :deaths :/death-id)
  70. :/marriage (in-table-column :marriages :/marriage-id)
  71. :/divorce (in-table-column :divorces :/divorce-id))
  72. ;;; The Notes table
  73. (defattributes
  74. :/note-id (unique-in-column :notes :/note-id integer)
  75. :/note-title #'stringp
  76. :/note-text #'stringp
  77. :/media-link #'stringp)
  78. ;;; The Reports Table
  79. (defattributes
  80. :/report-id (unique-in-column :reports :/report-id integer)
  81. :/report-title #'stringp
  82. :/report-type (constrain-values "tree" "full" "ahnentafel"))
  83. ;;; insert person
  84. (defun new-person (name gender birth-date mother father)
  85. (declare (string name)
  86. (integer mother
  87. father))
  88. (with-tx
  89. (let ((person-id (generate-table-id :people))
  90. (birth-id (generate-table-id :births)))
  91. (insert :people
  92. (list :/person-id person-id
  93. :/person-name name
  94. :/gender gender))
  95. (insert :births
  96. (list :/birth-id birth-id
  97. :/birth-person person-id
  98. :/birth-date birth-date
  99. :/mother mother
  100. :/father father))
  101. (values person-id birth-id))))
  102. ;;; insert death
  103. (defun new-death (person death-date)
  104. (with-tx
  105. (let ((death-id (generate-table-id :deaths)))
  106. (insert :deaths
  107. (list :/death-id death-id
  108. :/death-person person
  109. :/death-date death-date))
  110. death-id)))
  111. ;;; insert marriage
  112. (defun new-marriage (husband wife date end-date)
  113. (with-tx
  114. (let ((marriage-id (generate-table-id :marriages)))
  115. (insert :marriages
  116. (list :/marriage-id marriage-id
  117. :/husband husband
  118. :/wife wife
  119. :/wedding-date date
  120. :/end-date date))
  121. marriage-id)))
  122. ;;; insert divorce
  123. (defun new-divorce (marriage-id date)
  124. (with-tx
  125. (let ((divorce-id (generate-table-id :divorces)))
  126. (insert :divorces
  127. (list :/divorce-id divorce-id
  128. :/marriage marriage-id
  129. :/divorce-date date))
  130. divorce-id)))
  131. ;;; Query records
  132. ;;; Get Person
  133. (defun get-person (id)
  134. (with-tx
  135. (first
  136. (select :people
  137. (where (equal :/person-id id))))))
  138. ;;; Get Birth record (by person)
  139. (defun get-birth (id)
  140. (with-tx
  141. (first
  142. (select :births
  143. (where (equal :/birth-person id))))))
  144. ;;; Get Death Record
  145. (defun get-death (id)
  146. (with-tx
  147. (first
  148. (select :deaths
  149. (where (equal :/death-person id))))))
  150. ;;; get marriage (by husband/wife)
  151. (defun get-marriage (husband wife)
  152. (with-tx
  153. (first
  154. (select :marriages
  155. (where (and (equal :/wife wife)
  156. (equal :/husband husband)))))))
  157. ;; get marriage (by id)
  158. (defun get-marriage-id (marriage-id)
  159. (with-tx
  160. (first
  161. (select :marriages
  162. (where (and (equal :/marriage-id marriage-id)))))))
  163. ;;; get divorce (by marriage)
  164. (defun get-divorce (id)
  165. (with-tx
  166. (first
  167. (select :divorces
  168. (where (equal :/marriage id))))))