! Copyright (C) 2009 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators io kernel math math.parser namespaces peg.ebnf sequences splitting strings vectors ; IN: gene.gedcom TUPLE: gedcom source version date note level stack current individuals families notes ; TUPLE: individual name gender note events reference child-of spouse-of ; TUPLE: family husband wife children events ; TUPLE: note text ; TUPLE: event type date place note ; : ( -- family ) family new V{ } clone >>events V{ } clone >>children ; : ( type -- event ) event new swap >>type ; : ( -- individual ) individual new V{ } clone >>events V{ } clone >>child-of V{ } clone >>spouse-of ; : ( -- note ) note new ; TUPLE: line level link type text ; : ( type -- line ) line new swap >>type ; EBNF: parse-line _ = (" ")* number = [0-9]+ => [[ >string string>number ]] link = "@" (!("@") .)+ "@" => [[ second >string "@" "@" surround ]] type = [A-Z_]+ => [[ >string ]] text = .* => [[ >string ]] rule = number:level _ link?:link _ type:type _ text:text => [[ type level >>level link >>link text >>text ]] ;EBNF : ( -- gedcom ) gedcom new dup >>current V{ } clone >>stack H{ } clone >>individuals H{ } clone >>families H{ } clone >>notes -1 >>level ; : with-gedcom ( gedcom quot -- ) gedcom swap with-variable ; inline USE: prettyprint : gedcom-last ( -- object ) gedcom get stack>> last ; : gedcom-stack ( -- object ) gedcom get stack>> ; : gedcom-level ( -- n ) gedcom get level>> ; : gedcom-current ( -- n ) gedcom get current>> ; : families ( -- assoc ) gedcom get families>> ; : individuals ( -- assoc ) gedcom get individuals>> ; : notes ( -- assoc ) gedcom get notes>> ; : set-current ( object -- ) gedcom get swap >>current drop ; : get-current ( -- object ) gedcom get current>> ; : get-last ( -- object ) gedcom get stack>> last ; : add-event ( event individual -- event ) dupd events>> push ; : add-note ( note individual -- note ) over >>note drop ; : handle-linked-line ( line -- ) dup type>> { { "FAM" [ link>> families [ drop ] cache set-current ] } { "INDI" [ link>> individuals [ drop ] cache set-current ] } { "NOTE" [ dup text>> swap link>> notes [ drop ] cache swap >>text get-last add-note set-current ] } [ . drop ] } case ; : handle-unlinked-line ( line -- ) dup type>> { { "BIRT" [ drop "birth" get-last add-event set-current ] } { "CHIL" [ text>> individuals [ drop ] cache dup get-last children>> push drop ] } { "CONC" [ text>> get-last text>> swap append get-last swap >>text drop ] } { "CONT" [ text>> get-last text>> swap "\n" glue get-last swap >>text drop ] } { "DATE" [ gedcom-last swap text>> >>date drop ] } { "DEAT" [ drop "death" get-last add-event set-current ] } { "FAMC" [ text>> families [ drop ] cache dup get-last child-of>> push drop ] } { "FAMS" [ text>> families [ drop ] cache dup get-last spouse-of>> push drop ] } { "HEAD" [ drop gedcom get dup >>current drop ] } { "HUSB" [ text>> individuals [ drop ] cache get-last swap >>husband drop ] } { "MARR" [ drop "marriage" get-last add-event set-current ] } { "NAME" [ gedcom-last swap text>> >>name drop ] } { "NOTE" [ text>> swap >>text get-last add-note set-current ] } { "OCCU" [ drop "occupation" get-last add-event set-current ] } { "PLAC" [ gedcom-last swap text>> >>place drop ] } { "RESI" [ drop "residence" get-last add-event set-current ] } { "REFN" [ gedcom-last swap text>> >>reference drop ] } { "SEX" [ gedcom-last swap text>> >>gender drop ] } { "SOUR" [ gedcom-last swap text>> >>source drop ] } { "TRLR" [ drop ] } { "WIFE" [ text>> individuals [ drop ] cache get-last swap >>wife drop ] } { "VERS" [ gedcom-last swap text>> >>version drop ] } [ . drop ] } case ; : handle-line ( line -- ) dup link>> [ handle-linked-line ] [ handle-unlinked-line ] if ; : parse-gedcom-line ( string -- ) dup empty? [ drop ] [ parse-line ! "Line " write gedcom get stack>> length gedcom-level 2array . dup . dup level>> gedcom-level 1 - <= [ gedcom-level over level>> - [ gedcom-stack pop drop ] times ] when dup level>> gedcom-level 1 + = [ gedcom-current gedcom-stack push ] when gedcom get over level>> >>level drop handle-line ] if ; : parse-gedcom-lines ( lines -- gedcom ) tuck [ [ parse-gedcom-line ] each ] with-gedcom ; : parse-gedcom-string ( string -- gedcom ) string-lines parse-gedcom-lines ;