PageRenderTime 62ms CodeModel.GetById 32ms RepoModel.GetById 0ms app.codeStats 0ms

/src/test/clojure/topoged/test/entity.clj

https://github.com/m0smith/topoged
Clojure | 292 lines | 266 code | 26 blank | 0 comment | 6 complexity | c7b87ebbd02199f5667be0cf4548b383 MD5 | raw file
    

  1. (ns topoged.test.entity  
    2. 

  2.   (:use [clojure.java.io :only [reader writer input-stream output-stream]]
    3. 

  3. 	[clojure.contrib.seq-utils :only (find-first)]
    4. 

  4. 	[clojure.pprint :only (pprint)]
    5. 

  5. 	[topoged.file :only (copy-md5)]
    6. 

  6. 	[topoged.gedcom :only [gedcom-seq]]))
    7. 

  7. 

  8. (defn conjv
    9. 

  9.   ( [coll x] (conj (if coll coll #{}) x))
    10. 

  10.   ( [coll x & xs]
    11. 

  11.       (if xs
    12. 

  12. 	(recur (conjv coll x) (first xs) (rest xs))
    13. 

  13. 	(conjv coll x)))
    14. 

  14.   )
    15. 

  15. 

  16. (defstruct TYPE :TYPE_ID :TYPE_NAME)
    17. 

  17. 

  18. (defstruct SOURCE :SOURCE_ID :TYPE_ID)
    19. 

  19. (defstruct SOURCE_WITHIN_SOURCE :PARENT_SOURCE_ID :MEMBER_SOURCE_ID :ORDER)
    20. 

  20. (defstruct REPRESENTAITON :SOURCE_ID :TYPE_ID :CONTENT :COMMENTS)
    21. 

  21. (defstruct REPOSITORY :REPOSITORY_ID :TYPE_ID )
    22. 

  22. (defstruct REPOSITORY_SOURCE :REPOSITORY_ID :SOURCE_ID :CALL_NUMBER :DESCRIPTION)
    23. 

  23. (defstruct ATTRIBUTE_OWNER :OWNER_ID :OWNER_TYPE_ID :ATTRIBUTE_ID)
    24. 

  24. 

  25. 

  26. (defstruct PERSONA :PERSONA_ID)
    27. 

  27. (defstruct PERSONA_SOURCE :PERSONA_ID :SOURCE_ID :ID_IN_SOURCE)
    28. 

  28. 

  29. (defstruct GROUP :GROUP_ID :TYPE_ID)
    30. 

  30. (defstruct GROUP_SOURCE :GROUP_ID :SOURCE_ID :ID_IN_SOURCE)
    31. 

  31. 

  32. (defstruct ATTRIBUTE_ATTRIBUTE :PARENT_ATTRIBUTE_ID :MEMBER_ATTRIBUTE_ID)
    33. 

  33. (defstruct ATTRIBUTE :ATTRIBUTE_ID :TYPE_ID :VALUE)
    34. 

  34. 

  35. 

  36. (defn update-state [state key value]
    37. 

  37.   (update-in state [key] conjv value))
    38. 

  38. 

  39. 

  40. (defn find-type [state name]
    41. 

  41.   (let [types (:type state)]
    42. 

  42.     (first (filter #(= (:id %) name) types))))
    43. 

  43. 

  44. (def initial-state
    45. 

  45.      {
    46. 

  46.       :type, #{
    47. 

  47. 	       (struct TYPE "GEDCOM" "GEDCOM")
    48. 

  48. 	       (struct TYPE "REPOSITORY" "REPOSITORY")
    49. 

  49. 	       (struct TYPE "PERSONA" "PERSONA")
    50. 

  50. 	       (struct TYPE "GROUP" "GROUP")
    51. 

  51. 	       (struct TYPE "MD5" "MD5")
    52. 

  52. 	       (struct TYPE "text/plain" "text/plain")
    53. 

  53. 	       }
    54. 

  54. 

  55.       })
    56. 

  56. 

  57. (defn handler-factory [m]
    58. 

  58.   (fn [state rec]
    59. 

  59.     (if-let [func (get m (:tag rec))]
    60. 

  60.       (func state rec)
    61. 

  61.       state)))
    62. 

  62. 

  63. (defn match-in-fn [ [& ks] val]
    64. 

  64.   #(= val (get-in % ks)))
    65. 

  65. 

  66. 

  67. (defn subm-handler [source-zero]
    68. 

  68.   (fn [state rec]
    69. 

  69.     (let [repo-id (:value rec)
    70. 

  70. 	  state (-> state
    71. 

  71. 		    (update-state  :repository
    72. 

  72. 				   (struct REPOSITORY repo-id "HOME"))
    73. 

  73. 		    (update-state  :repository_source
    74. 

  74. 				   (struct REPOSITORY_SOURCE repo-id (:SOURCE_ID source-zero))))]
    75. 

  75.       (reduce #(let [line-number (get-in %2 [:attrs :line-number])
    76. 

  76. 		     rep (get-in %2 [:attrs :representation]) 
    77. 

  77. 		     tag (:tag %2)
    78. 

  78. 		     source-id (str "SOURCE" line-number)] 
    79. 

  79. 		 (-> %1
    80. 

  80. 		     (update-state :source
    81. 

  81. 				   (struct SOURCE
    82. 

  82. 					   source-id
    83. 

  83. 					   "LINE"))
    84. 

  84. 		     (update-state :source_within_source
    85. 

  85. 				   (struct SOURCE_WITHIN_SOURCE
    86. 

  86. 					   (:SOURCE_ID source-zero)
    87. 

  87. 					   source-id
    88. 

  88. 					   line-number))
    89. 

  89. 		     (update-state :representation
    90. 

  90. 				   (struct REPRESENTAITON
    91. 

  91. 					   source-id
    92. 

  92. 					   "text/plain"
    93. 

  93. 					   rep))
    94. 

  94. 		     (update-state :attribute
    95. 

  95. 				   (struct ATTRIBUTE
    96. 

  96. 					   (str "ATTR" line-number)
    97. 

  97. 					   (name tag)
    98. 

  98. 					   (:value %2)
    99. 

  99. 					   ))
    100. 

  100. 		     (update-state :type
    101. 

  101. 				   (struct TYPE (name tag) (name tag)))
    102. 

  102. 		     (update-state :attribute_owner
    103. 

  103. 				   (struct ATTRIBUTE_OWNER repo-id "REPOSITORY"
    104. 

  104. 					   (str "ATTR" line-number)))))
    105. 

  105. 	      
    106. 

  106. 	      state (:content rec)))))
    107. 

  107. 

  108. (defn indi-handler [source-zero]
    109. 

  109.   (fn [state rec]
    110. 

  110.     (let [persona-id (:value rec)
    111. 

  111. 		  line-number (get-in rec [:attrs :line-number])
    112. 

  112. 		  source-id (str "SOURCE" line-number)
    113. 

  113. 		  rep (get-in rec [:attrs :representation]) 
    114. 

  114. 		  state (-> state
    115. 

  115. 					(update-state :persona (struct PERSONA persona-id ))
    116. 

  116. 		    (update-state :source (struct SOURCE source-id "LINE"))
    117. 

  117. 		    (update-state :source_within_source
    118. 

  118. 				  (struct SOURCE_WITHIN_SOURCE
    119. 

  119. 					  (:SOURCE_ID source-zero)
    120. 

  120. 					  source-id line-number))
    121. 

  121. 		    (update-state :representation
    122. 

  122. 				  (struct REPRESENTAITON
    123. 

  123. 					  source-id
    124. 

  124. 					  "text/plain"
    125. 

  125. 					  rep))
    126. 

  126. 		    (update-state  :persona_source
    127. 

  127. 				   (struct PERSONA_SOURCE persona-id source-id persona-id)))]
    128. 

  128.       (letfn [(persona-attribute [state line-number]
    129. 

  129. 				 (update-state state :attribute_owner
    130. 

  130. 					       (struct ATTRIBUTE_OWNER persona-id "PERSONA"
    131. 

  131. 						       (str "ATTR" line-number))))
    132. 

  132. 	      (attr-attribute [attr-id]
    133. 

  133. 			      (fn [state line-number]
    134. 

  134. 				(update-state state :attribute_attribute
    135. 

  135. 					      (struct ATTRIBUTE_ATTRIBUTE attr-id
    136. 

  136. 						      (str "ATTR" line-number)))))
    137. 

  137. 	      (content-handler [attr-parent-func]
    138. 

  138. 			       (fn [state rec]
    139. 

  139. 				 (let [line-number (get-in rec [:attrs :line-number])
    140. 

  140. 				       rep (get-in rec [:attrs :representation]) 
    141. 

  141. 				       tag (:tag rec)
    142. 

  142. 				       source-id (str "SOURCE" line-number)] 
    143. 

  143. 				   (-> state
    144. 

  144. 				       (update-state :source
    145. 

  145. 						     (struct SOURCE
    146. 

  146. 							     source-id
    147. 

  147. 							     "LINE"))
    148. 

  148. 				       (update-state :source_within_source
    149. 

  149. 						     (struct SOURCE_WITHIN_SOURCE
    150. 

  150. 							     (:SOURCE_ID source-zero)
    151. 

  151. 							     source-id
    152. 

  152. 							     line-number))
    153. 

  153. 				       (update-state :representation
    154. 

  154. 						     (struct REPRESENTAITON
    155. 

  155. 							     source-id
    156. 

  156. 							     "text/plain"
    157. 

  157. 							     rep))
    158. 

  158. 				       (update-state :attribute
    159. 

  159. 						     (struct ATTRIBUTE
    160. 

  160. 							     (str "ATTR" line-number)
    161. 

  161. 							     (name tag)
    162. 

  162. 							     (:value rec)
    163. 

  163. 							     ))
    164. 

  164. 				       (update-state :type
    165. 

  165. 						     (struct TYPE (name tag) (name tag)))
    166. 

  166. 				       (attr-parent-func line-number)
    167. 

  167. 				       (reduce-content rec (attr-attribute  (str "ATTR" line-number)))
    168. 

  168. 				       ))))
    169. 

  169. 	      (reduce-content [state rec func]
    170. 

  170. 			      (if-let [content (seq (:content rec))]
    171. 

  171. 				(reduce (content-handler func) state content)
    172. 

  172. 				state))]
    173. 

  173. 	(reduce-content state rec persona-attribute)))))
    174. 

  174. 

  175. (defn fam-handler [source-zero]
    176. 

  176.   (fn [state rec]
    177. 

  177.     (let [group-id (:value rec)
    178. 

  178. 		  line-number (get-in rec [:attrs :line-number])
    179. 

  179. 		  source-id (str "SOURCE" line-number)
    180. 

  180. 		  rep (get-in rec [:attrs :representation]) 
    181. 

  181. 		  state (-> state
    182. 

  182. 			    (update-state :group (struct GROUP group-id "FAMILY"))
    183. 

  183. 		    (update-state :source (struct SOURCE source-id "LINE"))
    184. 

  184. 		    (update-state :source_within_source
    185. 

  185. 				  (struct SOURCE_WITHIN_SOURCE
    186. 

  186. 					  (:SOURCE_ID source-zero)
    187. 

  187. 					  source-id line-number))
    188. 

  188. 		    (update-state :representation
    189. 

  189. 				  (struct REPRESENTAITON
    190. 

  190. 					  source-id
    191. 

  191. 					  "text/plain"
    192. 

  192. 					  rep))
    193. 

  193. 		    (update-state  :group_source
    194. 

  194. 				   (struct GROUP_SOURCE group-id source-id group-id)))]
    195. 

  195.       (letfn [(group-attribute [state line-number]
    196. 

  196. 				 (update-state state :attribute_owner
    197. 

  197. 					       (struct ATTRIBUTE_OWNER group-id "GROUP"
    198. 

  198. 						       (str "ATTR" line-number))))
    199. 

  199. 	      (attr-attribute [attr-id]
    200. 

  200. 			      (fn [state line-number]
    201. 

  201. 				(update-state state :attribute_attribute
    202. 

  202. 					      (struct ATTRIBUTE_ATTRIBUTE attr-id
    203. 

  203. 						      (str "ATTR" line-number)))))
    204. 

  204. 	      (content-handler [attr-parent-func]
    205. 

  205. 			       (fn [state rec]
    206. 

  206. 				 (let [line-number (get-in rec [:attrs :line-number])
    207. 

  207. 				       rep (get-in rec [:attrs :representation]) 
    208. 

  208. 				       tag (:tag rec)
    209. 

  209. 				       source-id (str "SOURCE" line-number)] 
    210. 

  210. 				   (-> state
    211. 

  211. 				       (update-state :source
    212. 

  212. 						     (struct SOURCE
    213. 

  213. 							     source-id
    214. 

  214. 							     "LINE"))
    215. 

  215. 				       (update-state :source_within_source
    216. 

  216. 						     (struct SOURCE_WITHIN_SOURCE
    217. 

  217. 							     (:SOURCE_ID source-zero)
    218. 

  218. 							     source-id
    219. 

  219. 							     line-number))
    220. 

  220. 				       (update-state :representation
    221. 

  221. 						     (struct REPRESENTAITON
    222. 

  222. 							     source-id
    223. 

  223. 							     "text/plain"
    224. 

  224. 							     rep))
    225. 

  225. 				       (update-state :attribute
    226. 

  226. 						     (struct ATTRIBUTE
    227. 

  227. 							     (str "ATTR" line-number)
    228. 

  228. 							     (name tag)
    229. 

  229. 							     (:value rec)
    230. 

  230. 							     ))
    231. 

  231. 				       (update-state :type
    232. 

  232. 						     (struct TYPE (name tag) (name tag)))
    233. 

  233. 				       (attr-parent-func line-number)
    234. 

  234. 				       (reduce-content rec (attr-attribute  (str "ATTR" line-number)))
    235. 

  235. 				       ))))
    236. 

  236. 	      (reduce-content [state rec func]
    237. 

  237. 			      (if-let [content (seq (:content rec))]
    238. 

  238. 				(reduce (content-handler func) state content)
    239. 

  239. 				state))]
    240. 

  240. 	(reduce-content state rec group-attribute)))))
    241. 

  241. 

  242. (defn process-gedcom [f]
    243. 

  243.   (let [out-name "/tmp/f.ged"
    244. 

  244. 	source-zero (struct SOURCE "SOURCE0" "GEDCOM")
    245. 

  245. 	md5 (let [in  f
    246. 

  246. 		  out out-name]
    247. 

  247. 	      (copy-md5 in out))
    248. 

  248. 	state (merge initial-state
    249. 

  249. 		     { :source,
    250. 

  250. 		      #{
    251. 

  251. 			source-zero
    252. 

  252. 			}
    253. 

  253. 		      :representation
    254. 

  254. 		      #{
    255. 

  255. 			(struct REPRESENTAITON "GEDCOM" "MD5" md5)
    256. 

  256. 			(struct REPRESENTAITON "GEDCOM" "text/plain" (slurp out-name))
    257. 

  257. 			}
    258. 

  258. 		      })
    259. 

  259. 	handler (handler-factory
    260. 

  260. 		 {
    261. 

  261. 		  :HEAD #(merge %1 {:forward
    262. 

  262. 				    {
    263. 

  263. 				     (-> (find-first (match-in-fn [:tag] :SUBM) (:content %2) )
    264. 

  264. 					 :value)
    265. 

  265. 				     source-zero}})
    266. 

  266. 		  :SUBM (subm-handler source-zero)
    267. 

  267. 		  :INDI (indi-handler source-zero)
    268. 

  268. 		  :FAM (fam-handler source-zero)
    269. 

  269. 		  })]
    270. 

  270.     (with-open [rdr (reader out-name)]
    271. 

  271.       (reduce handler state  (gedcom-seq (line-seq rdr))))))
    272. 

  272. 

  273. (defn seq-csv [s]
    274. 

  274.   (let [q "\""]
    275. 

  275.     
    276. 

  276.     (if (seq s)
    277. 

  277.       (str q (apply str  (interpose  (str q "," q) s)) q \newline)
    278. 

  278.       (println s))))
    279. 

  279. 

  280. (defn to-csv [m]
    281. 

  281.   (apply str
    282. 

  282. 	 (map seq-csv
    283. 

  283. 	      (mapcat identity
    284. 

  284. 		      (for [key (sort (filter (complement #{:forward}) (keys m)))]
    285. 

  285. 			(let [recs (m key)
    286. 

  286. 			      kys (keys (first recs))]
    287. 

  287. 			  (concat [[ ""] [ ""] [ (str "TABLE: " (.toUpperCase (name key)))] (map name kys)]
    288. 

  288. 				  (for [rec (sort-by #(vec (map % kys)) recs)]
    289. 

  289. 				    (map get (repeat rec) kys)))))))))
    290. 

  290. 

  291. 

  292. (defn simp [] (spit "doc/simple.csv" (to-csv (process-gedcom "src/test/resources/simple.ged"))))
    293.