family.l (9608B)
1 # 19jul13abu 2 # (c) Software Lab. Alexander Burger 3 4 (load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/ps.l") 5 6 ### DB ### 7 (class +Person +Entity) 8 (rel nm (+Need +Sn +Idx +String)) # Name 9 (rel pa (+Joint) kids (+Man)) # Father 10 (rel ma (+Joint) kids (+Woman)) # Mother 11 (rel mate (+Joint) mate (+Person)) # Partner 12 (rel job (+Ref +String)) # Occupation 13 (rel dat (+Ref +Date)) # born 14 (rel fin (+Ref +Date)) # died 15 (rel txt (+String)) # Info 16 17 (dm url> (Tab) 18 (list "!person" '*ID This) ) 19 20 21 (class +Man +Person) 22 (rel kids (+List +Joint) pa (+Person)) # Children 23 24 (class +Woman +Person) 25 (rel kids (+List +Joint) ma (+Person)) # Children 26 27 (dbs 28 (0) # (1 . 64) 29 (2 +Person) # (2 . 256) 30 (3 (+Person nm)) # (3 . 512) 31 (3 (+Person job dat fin)) ) # (4 . 512) 32 33 34 ### GUI ### 35 (de choPerson (Dst) 36 (diaform '(Dst) 37 (<grid> "--.-.-." 38 "Name" (gui 'nm '(+Focus +Var +TextField) '*PrsNm 20) 39 "Occupation" (gui 'job '(+Var +TextField) '*PrsJob 20) 40 "born" (prog 41 (gui 'dat1 '(+Var +DateField) '*PrsDat1 10) 42 (gui 'dat2 '(+Var +DateField) '*PrsDat2 10) ) 43 (searchButton '(init> (: home query))) 44 "Father" (gui 'pa '(+Var +TextField) '*PrsPa 20) 45 "Mother" (gui 'ma '(+Var +TextField) '*PrsMa 20) 46 "Partner" (gui 'mate '(+Var +TextField) '*PrsMate 20) 47 (resetButton '(nm pa ma mate job dat1 dat2 query)) ) 48 (gui 'query '(+QueryChart) (cho) 49 '(goal 50 (quote 51 @Nm *PrsNm 52 @Pa *PrsPa 53 @Ma *PrsMa 54 @Mate *PrsMate 55 @Job *PrsJob 56 @Dat (and (or *PrsDat1 *PrsDat2) (cons *PrsDat1 (or *PrsDat2 T))) 57 (select (@@) 58 ((nm +Person @Nm) 59 (nm +Person @Pa kids) 60 (nm +Person @Ma kids) 61 (nm +Person @Mate mate) 62 (job +Person @Job) 63 (dat +Person @Dat) ) 64 (tolr @Nm @@ nm) 65 (tolr @Pa @@ pa nm) 66 (tolr @Ma @@ ma nm) 67 (tolr @Mate @@ mate nm) 68 (head @Job @@ job) 69 (range @Dat @@ dat) ) ) ) 70 7 71 '((This) (list This This (: pa) (: ma) (: mate) (: job) (: dat))) ) 72 (<table> 'chart NIL 73 '((btn) (NIL "Name") (NIL "Father") (NIL "Mother") (NIL "Partner") (NIL "Occupation") (NIL "born")) 74 (do (cho) 75 (<row> (alternating) 76 (gui 1 '(+DstButton) Dst) 77 (gui 2 '(+ObjView +TextField) '(: nm)) 78 (gui 3 '(+ObjView +TextField) '(: nm)) 79 (gui 4 '(+ObjView +TextField) '(: nm)) 80 (gui 5 '(+ObjView +TextField) '(: nm)) 81 (gui 6 '(+TextField)) 82 (gui 7 '(+DateField)) ) ) ) 83 (<spread> 84 (scroll (cho)) 85 (<nbsp> 4) 86 (prin "Man") 87 (newButton T Dst '(+Man) 'nm *PrsNm) 88 (<nbsp>) 89 (prin "Woman") 90 (newButton T Dst '(+Woman) 'nm *PrsNm) 91 (<nbsp> 4) 92 (cancelButton) ) ) ) 93 94 # Person HTML Page 95 (de person () 96 (app) 97 (action 98 (html 0 (get (default *ID (val *DB)) 'nm) "@lib.css" NIL 99 (form NIL 100 (<h2> NIL (<id> (: nm))) 101 (panel T "Person '@1'" T '(choPerson) 'nm '+Person) 102 (<p> NIL 103 (gui '(+E/R +TextField) '(nm : home obj) 40 "Name") 104 (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman))) ) 105 (<grid> 5 106 "Occupation" (gui '(+E/R +TextField) '(job : home obj) 20) 107 "Father" (choPerson 0) 108 (gui '(+E/R +Obj +TextField) '(pa : home obj) '(nm +Man) 30) 109 "born" (gui '(+E/R +DateField) '(dat : home obj) 10) 110 "Mother" (choPerson 0) 111 (gui '(+E/R +Obj +TextField) '(ma : home obj) '(nm +Woman) 30) 112 "died" (gui '(+E/R +DateField) '(fin : home obj) 10) 113 "Partner" (choPerson 0) 114 (gui '(+E/R +Obj +TextField) '(mate : home obj) '(nm +Person) 30) ) 115 (gui '(+E/R +Chart) '(kids : home obj) 5 116 '((This) (list NIL This (: dat) (: pa) (: ma))) 117 cadr ) 118 (<table> NIL NIL 119 '(NIL (NIL "Children") (NIL "born") (NIL "Father") (NIL "Mother")) 120 (do 4 121 (<row> NIL 122 (choPerson 1) 123 (gui 2 '(+Obj +TextField) '(nm +Person) 20) 124 (gui 3 '(+E/R +DateField) '(dat curr) 10) 125 (gui 4 '(+ObjView +TextField) '(: nm) 20) 126 (gui 5 '(+ObjView +TextField) '(: nm) 20) ) ) 127 (<row> NIL NIL (scroll 4)) ) 128 (----) 129 (gui '(+E/R +TextField) '(txt : home obj) 40 4) 130 (gui '(+Rid +Button) "Contemporaries" 131 '(url "!contemporaries" (: home obj)) ) 132 (gui '(+Rid +Button) "Tree View" 133 '(url "!treeReport" (: home obj)) ) 134 (editButton T) ) ) ) ) 135 136 137 ### Reports ### 138 # Show all contemporaries of a person 139 (de contemporaries (*ID) 140 (action 141 (html 0 "Contemporaries" "@lib.css" NIL 142 (form NIL 143 (<h3> NIL (<id> "Contemporaries of " (: nm))) 144 (ifn (: obj dat) 145 (<h3> NIL (ht:Prin "No birth date for " (: obj nm))) 146 (gui '(+QueryChart) 12 147 '(goal 148 (quote 149 @Obj (: home obj) 150 @Dat (: home obj dat) 151 @Beg (- (: home obj dat) 36525) 152 @Fin (or (: home obj fin) (+ (: home obj dat) 36525)) 153 (db dat +Person (@Beg . @Fin) @@) 154 (different @@ @Obj) 155 (^ @ (>= (get (-> @@) 'fin) (-> @Dat))) 156 (^ @ (<= (get (-> @@) 'dat) (-> @Fin))) ) ) 157 7 158 '((This) 159 (list This (: job) (: dat) (: fin) (: pa) (: ma) (: mate)) ) ) 160 (<table> NIL (pack (datStr (: obj dat)) " - " (datStr (: obj fin))) 161 (quote 162 (NIL "Name") (NIL "Occupation") (NIL "born") (NIL "died") 163 (NIL "Father") (NIL "Mother") (NIL "Partner") ) 164 (do 12 165 (<row> NIL 166 (gui 1 '(+ObjView +TextField) '(: nm)) 167 (gui 2 '(+TextField)) 168 (gui 3 '(+DateField)) 169 (gui 4 '(+DateField)) 170 (gui 5 '(+ObjView +TextField) '(: nm)) 171 (gui 6 '(+ObjView +TextField) '(: nm)) 172 (gui 7 '(+ObjView +TextField) '(: nm)) ) ) ) 173 (scroll 12) 174 (----) 175 (gui '(+Rid +Button) "Textfile" 176 '(let Txt (tmp "Contemporaries.txt") 177 (out Txt (txt> (chart))) 178 (url Txt) ) ) 179 (gui '(+Rid +Button) "PDF" 180 '(psOut NIL "Contemporaries" 181 (out (tmp "Contemporaries.txt") 182 (txt> (chart)) ) 183 (in (tmp "Contemporaries.txt") 184 (let (Page 1 Fmt (200 120 50 50 120 120 120) Ttl (line T)) 185 (a4L "Contemporaries") 186 (font (7 . "Helvetica")) 187 (indent 30 10) 188 (down 12) 189 (font 9 (ps Ttl)) 190 (down 12) 191 (table Fmt 192 "Name" "Occupation" "born" "died" "Father" "Mother" "Partner" ) 193 (down 6) 194 (pages 560 195 (page T) 196 (down 12) 197 (ps (pack Ttl ", Page " (inc 'Page))) 198 (down 12) ) 199 (until (eof) 200 (let L (split (line) "^I") 201 (down 8) 202 (table Fmt 203 (font "Helvetica-Bold" (ps (head 50 (car L)))) 204 (ps (head 30 (cadr L))) 205 (ps (get L 3)) 206 (ps (get L 4)) 207 (ps (head 30 (get L 5))) 208 (ps (head 30 (get L 6))) 209 (ps (head 30 (get L 7))) ) 210 (down 4) ) ) ) ) 211 (page) ) ) ) ) ) ) ) 212 213 # Tree display of a person's descendants 214 (de treeReport (This) 215 (html 0 "Family Tree View" "@lib.css" NIL 216 (<h3> NIL "Family Tree View") 217 (<ul> NIL 218 (recur (This) 219 (when (try 'url> This 1) 220 (<li> NIL 221 (<href> (: nm) (mkUrl @)) 222 (when (try 'url> (: mate) 1) 223 (prin " -- ") 224 (<href> (: mate nm) (mkUrl @)) ) ) 225 (when (: kids) 226 (<ul> NIL (mapc recurse (: kids))) ) ) ) ) ) ) 227 228 ### RUN ### 229 (de main () 230 (pool "family/" *Dbs) 231 (unless (val *DB) 232 (put> 233 (set *DB (request '(+Man) 'nm "Adam")) 234 'mate 235 (request '(+Woman) 'nm "Eve") ) 236 (commit) ) ) 237 238 (de go () 239 (rollback) 240 (server 8080 "!person") ) 241 242 # vi:et:ts=3:sw=3