ahnentafel.lisp 2.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960
  1. ;;;; ahnentafel.lisp
  2. (in-package #:genie)
  3. ;;; "ahnentafel" goes here. Hacks and glory await!
  4. (defun generate-ahnentafel-numbers (starting-person number-of-generations)
  5. (flet ((get-father (person)
  6. (:/father (get-birth person)))
  7. (get-mother (person)
  8. (:/mother (get-birth person)))
  9. (generate-number (current gender)
  10. (if (string= gender "M")
  11. (* 2 current)
  12. (1+ (* 2 current)))))
  13. (let ((ahnentafel-list (cons (cons 1 starting-person) nil)))
  14. (labels ((recurse (person number generation gender)
  15. (if (not (= generation 0))
  16. (let ((new-number (generate-number number gender))
  17. (father (get-father person))
  18. (mother (get-mother person)))
  19. (push (cons new-number person) ahnentafel-list)
  20. (if (not (= 0 father))
  21. (recurse father new-number (1- generation) "M"))
  22. (if (not (= 0 mother))
  23. (recurse mother new-number (1- generation) "F"))))))
  24. (recurse (get-father starting-person) 1 (1- number-of-generations) "M")
  25. (recurse (get-mother starting-person) 1 (1- number-of-generations) "F"))
  26. ahnentafel-list)))
  27. (defun generate-ahnentafel-text (ahnentafel)
  28. (map 'list (lambda (record)
  29. (let* ((num (car record))
  30. (person (cdr record))
  31. (name (:/person-name (get-person person)))
  32. (birthdate (:/birth-date (get-birth person)))
  33. (death (let ((death-record (get-death person)))
  34. (if (null death-record)
  35. ""
  36. (format nil " -- ~a" (:/death-date death-record))))))
  37. (cons num
  38. (format nil
  39. "~a, ~a~a"
  40. name
  41. birthdate
  42. death))))
  43. ahnentafel))
  44. (defun print-ahnentafel (file start generations)
  45. (let* ((ahnentafel-numbers (generate-ahnentafel-numbers start generations))
  46. (ahnentafel-with-text (generate-ahnentafel-text ahnentafel-numbers))
  47. (sorted-ahnentafel (sort ahnentafel-with-text #'< :key #'car))
  48. (sorted-ahnentafel-mapping (sort ahnentafel-numbers #'< :key #'car)))
  49. (with-open-file (output file
  50. :direction :output
  51. :if-exists :overwrite
  52. :if-does-not-exist :create)
  53. (iter (for (number . text) in sorted-ahnentafel)
  54. (format output "~10,5R: ~A~&" number text)))
  55. (values sorted-ahnentafel-mapping sorted-ahnentafel)))