family-tree 0.2 → 0.3.0.0
raw patch · 3 files changed
+380/−259 lines, 3 filesdep +intervalsdep +lensdep −data-lensdep ~basedep ~binarydep ~containers
Dependencies added: intervals, lens
Dependencies removed: data-lens
Dependency ranges changed: base, binary, containers, text, time, unordered-containers
Files
- LICENSE +22/−16
- family-tree.cabal +64/−24
- src/Data/FamilyTree.hs +294/−219
LICENSE view
@@ -1,24 +1,30 @@ Copyright (c) 2012, Nathan "Taneb" van Doorn+ All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.- * Neither the name of the <organization> nor the- names of its contributors may be used to endorse or promote products- derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL NATHAN "TANEB" VAN DOORN BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Nathan "Taneb" van Doorn nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
family-tree.cabal view
@@ -1,28 +1,68 @@-name: family-tree-version: 0.2-cabal-version: >= 1.2-build-type: Simple-author: Nathan "Taneb" van Doorn-maintainer: nvd1234@gmail.com-stability: Unstable-synopsis: Family trees with lenses+-- Initial family-tree.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ -description: This is a module for the manipulation of family trees.-category: Genealogy, Data-copyright: (c) 2012 Nathan "Taneb" van Doorn-license: BSD3-license-file: LICENSE+-- The name of the package.+name: family-tree +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.3.0.0++package-url: https://github.com/Taneb/family-tree++-- A short (one-line) description of the package.+synopsis: A family tree library for the Haskell programming language.++-- A longer description of the package.+description: A family tree library for the Haskell programming language.+ + Uses "Control.Lens" for modification and "Data.Binary" for+ serialization.++-- URL for the project homepage or repository.+homepage: https://github.com/Taneb/family-tree++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Nathan "Taneb" van Doorn++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: nvd1234@gmail.com++-- A copyright notice.+-- copyright: ++category: Data, Genealogy++build-type: Simple++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.8++ library- hs-source-dirs: src- build-depends: - base >= 4 && < 5,- text < 0.12,- containers >= 0.4.2 && < 0.6,- unordered-containers < 0.3,- time < 2,- data-lens < 3,- binary < 0.6- ghc-options: -Wall- exposed-modules: Data.FamilyTree+ -- Modules exported by the library.+ exposed-modules: Data.FamilyTree+ + -- Modules included in this library but not exported.+ -- other-modules: + + -- Other library packages from which modules are imported.+ build-depends: base >= 4.3 && < 5, lens >= 3.7 && < 3.9, binary < 0.7, unordered-containers ==0.2.*, containers >=0.42 && < 0.6, text ==0.11.*, time < 1.5, intervals < 0.3+ + -- Directories containing source files.+ hs-source-dirs: src +source-repository head+ type: git+ location: git://github.com/Taneb/family-tree.git
src/Data/FamilyTree.hs view
@@ -1,4 +1,9 @@-{- |+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -Wall #-}+{-| Maintainer : nvd124@gmail.com Stability : unstable Portability : portable@@ -17,9 +22,30 @@ -- * Types -- ** Main types Person(..),+ name,+ attributes,+ birthdate,+ birthplace,+ deathdate,+ deathplace,+ attendedEvents, Family(..),+ head1,+ head2,+ children,+ relationFrom,+ relationTo,+ relationship, Event(..),+ eventInfo,+ eventDate,+ eventAttendees,+ FamilyTree(..),+ treeName,+ people,+ families,+ events, -- ** ID types -- $ids PersonID(..),@@ -35,25 +61,28 @@ addFamily, addEvent, -- ** Manipulation- personLens,- familyLens,- eventLens,+ traversePerson,+ traverseFamily,+ traverseEvent, -- ** Destruction deletePerson, deleteFamily,- deleteEvent+ deleteEvent,+ -- * Utility functions+ partialDateFromYear,+ partialDateFromMonth,+ partialDateFromDay ) where -import Control.Applicative ((<$>))-import Control.Arrow ((***))-import Control.Monad (join)+import Control.Applicative (Applicative(..), (<$>), Alternative(..))+import Control.Lens hiding (children) -import Data.Binary (Binary, get, put, Word8, getWord8)+import Data.Binary (Word8, Binary(..), getWord8) import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import Data.Lens.Common (Lens, lens) import Data.Maybe (listToMaybe)+import Data.Monoid (Monoid(..), First(..)) import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.IntSet (IntSet)@@ -61,61 +90,154 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import Data.Time (Day(..))+import Data.Time (Day(..), fromGregorian, gregorianMonthLength) +import Numeric.Interval (Interval)+import qualified Numeric.Interval as I++-- $ids+-- The various ID types represent an identifier for a person, family, or event. +-- While the constructors are exported, it is probably better to use the+-- various 'Traversal's for manipulation, as they echo the changes around the+-- tree automatically.+newtype PersonID = PersonID {getPersonID :: Int} deriving (Eq, Ord, Show, Read)++instance Wrapped Int Int PersonID PersonID where+ wrapped = iso PersonID getPersonID++newtype FamilyID = FamilyID {getFamilyID :: Int} deriving (Eq, Ord, Show, Read)++instance Wrapped Int Int FamilyID FamilyID where+ wrapped = iso FamilyID getFamilyID++newtype EventID = EventID {getEventID :: Int} deriving (Eq, Ord, Show, Read)++instance Wrapped Int Int EventID EventID where+ wrapped = iso EventID getEventID++-- | The Location type. Either a coordinate or a placename. +data Location = Coord Double Double | PlaceName Text deriving (Eq, Show)++-- | The Relationship type. Marriage is the default for similarity to GEDCOM.+data Relationship = Marriage | Other Text deriving (Eq, Show)++type PartialDate = Interval Day++partialDateFromYear :: Integer -> PartialDate+partialDateFromYear n = I.I (fromGregorian n 1 1) (fromGregorian n 12 31)++partialDateFromMonth :: Integer -> Int -> PartialDate+partialDateFromMonth y m = I.I (fromGregorian y m 1) . + fromGregorian y m $ gregorianMonthLength y m++partialDateFromDay :: Integer -> Int -> Int -> PartialDate+partialDateFromDay y m d = I.singleton $ fromGregorian y m d+ -- | The basic type for a person. 'Nothing' meaning unknown (or otherwise -- non-existent, for intance a death date for someone still alive) is a -- convention used throughout this library. data Person = Person- {name :: Maybe Text- ,birthdate :: Maybe Day- ,birthplace :: Maybe Location- ,deathdate :: Maybe Day- ,deathplace :: Maybe Location- ,attributes :: HashMap Text Text- ,attendedEvents :: IntSet+ {_name :: Maybe Text+ ,_birthdate :: Maybe PartialDate+ ,_birthplace :: Maybe Location+ ,_deathdate :: Maybe PartialDate+ ,_deathplace :: Maybe Location+ ,_attributes :: HashMap Text Text+ ,_attendedEvents :: IntSet } deriving (Eq, Show)+ +makeLenses ''Person -- | The basic type for a family. Which person is head1 and which is head2 is -- arbitrary, but try to use a consistent rule data Family = Family- {head1 :: Maybe Int- ,head2 :: Maybe Int- ,relationship :: Maybe Relationship- ,relationFrom :: Maybe Day- ,relationTo :: Maybe Day- ,children :: IntSet+ {_head1 :: Maybe PersonID+ ,_head2 :: Maybe PersonID+ ,_relationship :: Maybe Relationship+ ,_relationFrom :: Maybe PartialDate+ ,_relationTo :: Maybe PartialDate+ ,_children :: IntSet } deriving (Eq, Show) +makeLenses ''Family+ -- | The basic type for an event. For example: -- -- @ -- Event {--- eventInfo = \"Battle of Agincourt\"--- eventDate = fromGregorianValid 1415 10 25--- eventAttendees = IM.empty+-- _eventInfo = \"Battle of Agincourt\"+-- _eventDate = fromGregorianValid 1415 10 25+-- _eventAttendees = IM.empty -- } -- @ data Event = Event - {eventInfo :: Text- ,eventDate :: Maybe Day- ,eventAttendees :: IntSet+ {_eventInfo :: Text+ ,_eventDate :: Maybe PartialDate+ ,_eventAttendees :: IntSet } deriving (Eq, Show) --- | The Location type. Either a coordinate or a placename. -data Location = Coord Double Double | PlaceName Text deriving (Eq, Show)---- | The Relationship type. Marriage is the default for similarity to GEDCOM.-data Relationship = Marriage | Other Text deriving (Eq, Show)+makeLenses ''Event -- | The core structure of a family tree. data FamilyTree = FamilyTree- {treeName :: Text- ,people :: IntMap Person- ,families :: IntMap Family- ,events :: IntMap Event+ {_treeName :: Text+ ,_people :: IntMap Person+ ,_families :: IntMap Family+ ,_events :: IntMap Event } deriving (Eq, Show) +makeLenses ''FamilyTree++instance Monoid Person where+ mempty = Person {+ _name = Nothing,+ _birthdate = Nothing,+ _birthplace = Nothing,+ _deathdate = Nothing,+ _deathplace = Nothing,+ _attributes = HM.empty,+ _attendedEvents = IS.empty+ }+ p1 `mappend` p2 = Person {+ _name = ((<|>) `on` _name) p1 p2,+ _birthdate = ((<|>) `on` _birthdate) p1 p2,+ _birthplace = ((<|>) `on` _birthplace) p1 p2,+ _deathdate = ((<|>) `on` _deathdate) p1 p2,+ _deathplace = ((<|>) `on` _deathplace) p1 p2,+ _attributes = (HM.union `on` _attributes) p1 p2,+ _attendedEvents = (IS.union `on` _attendedEvents) p1 p2+ }++instance Monoid Family where+ mempty = Family {+ _head1 = Nothing,+ _head2 = Nothing,+ _relationship = Nothing,+ _relationFrom = Nothing,+ _relationTo = Nothing,+ _children = IS.empty+ }+ f1 `mappend` f2 = Family {+ _head1 = getFirst $ (mappend `on` First . _head1) f1 f2,+ _head2 = getFirst $ (mappend `on` First . _head2) f1 f2,+ _relationship = getFirst $ (mappend `on` First . _relationship) f1 f2,+ _relationFrom = getFirst $ (mappend `on` First . _relationFrom) f1 f2,+ _relationTo = getFirst $ (mappend `on` First . _relationTo) f1 f2,+ _children = (IS.union `on` _children) f1 f2+ }++instance Monoid Event where+ mempty = Event {+ _eventInfo = T.empty,+ _eventDate = Nothing,+ _eventAttendees = IS.empty+ }+ e1 `mappend` e2 = Event {+ _eventInfo = (T.append `on` _eventInfo) e1 e2,+ _eventDate = getFirst $ (mappend `on` First . _eventDate) e1 e2,+ _eventAttendees = (IS.union `on` _eventAttendees) e1 e2+ }+ instance Binary Location where put (Coord x y) = do put (0 :: Word8)@@ -146,262 +268,215 @@ instance Binary Person where put person = do- put (encodeUtf8 <$> name person)- put (toModifiedJulianDay <$> birthdate person)- put (birthplace person)- put (toModifiedJulianDay <$> deathdate person)- put (deathplace person)- put (map (join (***) encodeUtf8) . HM.toList $ attributes person)- put (attendedEvents person)+ put (encodeUtf8 <$> _name person)+ put (toModifiedJulianDay . I.inf <$> _birthdate person)+ put (toModifiedJulianDay . I.sup <$> _birthdate person)+ put (_birthplace person)+ put (toModifiedJulianDay . I.inf <$> _deathdate person)+ put (toModifiedJulianDay . I.sup <$> _deathdate person)+ put (_deathplace person)+ put (map (both %~ encodeUtf8) . HM.toList $ _attributes person)+ put (_attendedEvents person) get = do n <- get- bd <- get+ bdi <- get+ bds <- get bp <- get- dd <- get+ ddi <- get+ dds <- get dp <- get a <- get e <- get return Person- {name = fmap decodeUtf8 n- ,birthdate = fmap ModifiedJulianDay bd- ,birthplace = bp- ,deathdate = fmap ModifiedJulianDay dd- ,deathplace = dp- ,attributes = HM.fromList $ map (join (***) decodeUtf8) a- ,attendedEvents = e+ {_name = fmap decodeUtf8 n+ ,_birthdate = I.I <$> fmap ModifiedJulianDay bdi <*>+ fmap ModifiedJulianDay bds+ ,_birthplace = bp+ ,_deathdate = I.I <$> fmap ModifiedJulianDay ddi <*>+ fmap ModifiedJulianDay dds+ ,_deathplace = dp+ ,_attributes = HM.fromList $ map (both %~ decodeUtf8) a+ ,_attendedEvents = e } instance Binary Family where put fam = do- put $ head1 fam- put $ head2 fam- put $ relationship fam- put $ toModifiedJulianDay <$> relationFrom fam- put $ toModifiedJulianDay <$> relationTo fam- put $ children fam+ put $ getPersonID <$> _head1 fam+ put $ getPersonID <$> _head2 fam+ put $ _relationship fam+ put $ toModifiedJulianDay . I.inf <$> _relationFrom fam+ put $ toModifiedJulianDay . I.sup <$> _relationFrom fam+ put $ toModifiedJulianDay . I.inf <$> _relationTo fam+ put $ toModifiedJulianDay . I.sup <$> _relationTo fam+ put $ _children fam get = do h1 <- get h2 <- get r <- get- rf <- get- rt <- get+ rfi <- get+ rfs <- get+ rti <- get+ rts <- get c <- get return Family- {head1 = h1- ,head2 = h2- ,relationship = r- ,relationFrom = fmap ModifiedJulianDay rf- ,relationTo = fmap ModifiedJulianDay rt- ,children = c+ {_head1 = PersonID <$> h1+ ,_head2 = PersonID <$> h2+ ,_relationship = r+ ,_relationFrom = I.I <$> fmap ModifiedJulianDay rfi <*> fmap ModifiedJulianDay rfs+ ,_relationTo = I.I <$> fmap ModifiedJulianDay rti <*> fmap ModifiedJulianDay rts+ ,_children = c } instance Binary Event where put evnt = do- put . encodeUtf8 $ eventInfo evnt- put $ toModifiedJulianDay <$> eventDate evnt- put $ eventAttendees evnt+ put . encodeUtf8 $ _eventInfo evnt+ put $ toModifiedJulianDay . I.inf <$> _eventDate evnt+ put $ toModifiedJulianDay . I.sup <$> _eventDate evnt+ put $ _eventAttendees evnt get = do n <- get- d <- get+ di <- get+ ds <- get a <- get return Event- {eventInfo = decodeUtf8 n- ,eventDate = fmap ModifiedJulianDay d- ,eventAttendees = a+ {_eventInfo = decodeUtf8 n+ ,_eventDate = I.I <$> fmap ModifiedJulianDay di <*> fmap ModifiedJulianDay ds+ ,_eventAttendees = a } instance Binary FamilyTree where put tree = do- put $ encodeUtf8 $ treeName tree- put $ people tree- put $ families tree- put $ events tree+ put $ encodeUtf8 $ _treeName tree+ put $ _people tree+ put $ _families tree+ put $ _events tree get = do n <- get p <- get f <- get e <- get return FamilyTree- {treeName = decodeUtf8 n- ,people = p- ,families = f- ,events = e+ {_treeName = decodeUtf8 n+ ,_people = p+ ,_families = f+ ,_events = e } --- $ids--- The various ID types represent an identifier for a person, family, or event. --- While the constructors are exported, it is probably better to use the--- various lenses for manipulation, as they echo the changes around the tree--- automatically.-newtype PersonID = PersonID Int--newtype FamilyID = FamilyID Int--newtype EventID = EventID Int---- | Constructs a lens for the manipulation of a person in a family tree, from--- that person's ID. Using an ID that does not correspond to a person is an--- error, and it is impossible to create or destroy people using a lens created--- by this. -personLens :: PersonID -> Lens FamilyTree Person-personLens (PersonID n) = lens ((IM.! n) . people) $- \person familyTree ->- let oldPerson = people familyTree IM.! n- newattended = (IS.difference `on` attendedEvents)- person oldPerson- oldattended = (IS.difference `on` attendedEvents)- oldPerson person - in familyTree- {people = IM.insert n person (people familyTree)- ,events = IS.foldr (\i -> IM.adjust- (\event -> event - {eventAttendees = IS.delete i (eventAttendees event)}) i)- (IS.foldr (\i -> IM.adjust- (\event -> event - {eventAttendees = IS.insert i (eventAttendees event)}) i)- (events familyTree) newattended) oldattended- }+-- | Constructs a 'Traversal' for the manipulation of a person in a family tree, from+-- that person's ID. +traversePerson :: PersonID -> SimpleIndexedTraversal PersonID FamilyTree Person+traversePerson (PersonID n) = indexed $+ \f familyTree -> case familyTree ^. people . at n of+ Nothing -> pure familyTree+ Just oldPerson -> + let newPerson_ = f (PersonID n) oldPerson+ newEvents_ = flip (IS.difference `on` _attendedEvents) oldPerson+ <$> newPerson_+ oldEvents_ = (IS.difference `on` _attendedEvents) oldPerson+ <$> newPerson_+ in alterPerson familyTree <$> newPerson_ <*> newEvents_ <*> oldEvents_+ where+ alterPerson familyTree newPerson =+ IS.foldr (\i -> events . _at i . eventAttendees %~ IS.delete n) .+ IS.foldr (\i -> events . _at i . eventAttendees %~ IS.insert n) (+ people . _at n .~ newPerson $ familyTree) -- | Constructs a lens for the manipulation of a family in a family tree, from--- that family's ID. Using an ID that does not correspond to a family is an--- error, and it is impossible to create or destroy families using a lens--- created by this. -familyLens :: FamilyID -> Lens FamilyTree Family-familyLens (FamilyID n) = lens ((IM.! n) . families) $- \family' familyTree ->- familyTree- {families = IM.insert n family' (families familyTree)- }+-- that family's ID.+traverseFamily :: FamilyID -> SimpleIndexedTraversal FamilyID FamilyTree Family+traverseFamily (FamilyID n) = indexed $+ \f familyTree -> case familyTree ^. families . at n of+ Nothing -> pure familyTree+ Just oldFamily -> let newFamily_ = f (FamilyID n) oldFamily+ in alterFamily familyTree <$> newFamily_+ where+ alterFamily familyTree newFamily =+ familyTree & families . _at n .~ newFamily --- | Constructs a lens for the manipulation of an event in a family tree, from--- that event's ID. Using an ID that does not correspond to an event is an--- error, and it is impossible to create or destroy events using a lens created--- by this. -eventLens :: EventID -> Lens FamilyTree Event-eventLens (EventID n) = lens ((IM.! n) . events) $- \event familyTree ->- familyTree- {events = IM.insert n event (events familyTree)- ,people =- let oldEventPeople =- eventAttendees (events familyTree IM.! n)- IS.\\ eventAttendees event- newEventPeople = - eventAttendees event- IS.\\ eventAttendees (events familyTree IM.! n)- in IS.foldr- (IM.adjust (\ person -> person- {attendedEvents = IS.insert n (attendedEvents person)}))- (IS.foldr- (IM.adjust (\person -> person - {attendedEvents = IS.delete n (attendedEvents person)}))- (people familyTree)- oldEventPeople)- newEventPeople- }- -blankPerson :: Person-blankPerson = Person- {name = Nothing- ,birthdate = Nothing- ,birthplace = Nothing- ,deathdate = Nothing- ,deathplace = Nothing- ,attributes = HM.empty- ,attendedEvents = IS.empty- }- -blankFamily :: Family-blankFamily = Family- {head1 = Nothing- ,head2 = Nothing- ,relationship = Nothing- ,relationFrom = Nothing- ,relationTo = Nothing- ,children = IS.empty- }- -blankEvent :: Event-blankEvent = Event- {eventInfo = T.empty- ,eventDate = Nothing- ,eventAttendees = IS.empty- }+-- | Constructs a 'Traversal' for the manipulation of an event in a family tree, from+-- that event's ID. +traverseEvent :: EventID -> SimpleIndexedTraversal EventID FamilyTree Event+traverseEvent (EventID n) = indexed $+ \f familyTree -> case familyTree ^. events . at n of+ Nothing -> pure familyTree+ Just oldEvent ->+ let newEvent_ = f (EventID n) oldEvent+ oldPeople_ = (IS.difference `on` _eventAttendees) oldEvent+ <$> newEvent_+ newPeople_ = flip (IS.difference `on` _eventAttendees) oldEvent+ <$> newEvent_+ in alterEvent familyTree <$> newEvent_ <*> newPeople_ <*> oldPeople_+ where+ alterEvent familyTree newEvent =+ IS.foldr (\i -> people . _at i . attendedEvents %~ IS.delete n) .+ IS.foldr (\i -> people . _at i . attendedEvents %~ IS.insert n) (+ events . _at n .~ newEvent $ familyTree) -- | Adds a person with minimal information, returning the updated family tree -- and the ID of the new person. -addPerson :: FamilyTree -> (FamilyTree, PersonID)+addPerson :: FamilyTree -> (PersonID, FamilyTree) addPerson familyTree = let n = maybe 0 fst $ listToMaybe $ dropWhile (uncurry (==)) $- zip [1 ..] $ IM.keys $ people familyTree- in (familyTree- {people = IM.insert n blankPerson $ people familyTree}, PersonID n)+ zip [1 ..] $ IM.keys $ _people familyTree+ in (PersonID n, people . at n ?~ mempty $ familyTree) -- | Adds a family with minimal information, returning the updated family tree -- and the ID of the new family. -addFamily :: FamilyTree -> (FamilyTree, FamilyID)+addFamily :: FamilyTree -> (FamilyID, FamilyTree) addFamily familyTree = let n = maybe 0 fst $ listToMaybe $ dropWhile (uncurry (==)) $- zip [1 ..] $ IM.keys $ families familyTree- in (familyTree - {families = IM.insert n blankFamily $ families familyTree}, FamilyID n)+ zip [1 ..] $ IM.keys $ _families familyTree+ in (FamilyID n, families . at n ?~ mempty $ familyTree) -- | Adds an event with minimal information, returning the updated family tree -- and the ID of the new event.-addEvent :: FamilyTree -> (FamilyTree, EventID)+addEvent :: FamilyTree -> (EventID, FamilyTree) addEvent familyTree = let n = maybe 0 fst $ listToMaybe $ dropWhile (uncurry (==)) $- zip [1 ..] $ IM.keys $ events familyTree- in (familyTree {events = IM.insert n blankEvent $ events familyTree}, EventID n)+ zip [1 ..] $ IM.keys $ _events familyTree+ in (EventID n, events . at n ?~ mempty $ familyTree) -- | Deletes a person from the family tree, removing all references to them. deletePerson :: PersonID -> FamilyTree -> FamilyTree deletePerson (PersonID n) familyTree =- familyTree - {people = IM.delete n $ people familyTree- ,families = IM.map- (\fam -> fam- {head1 = if head1 fam == Just n then Nothing else head1 fam- ,head2 = if head2 fam == Just n then Nothing else head2 fam- ,children = IS.delete n $ children fam- }- )- (families familyTree)- ,events = IM.map- (\evnt -> evnt- {eventAttendees = IS.delete n $ eventAttendees evnt}- )- (events familyTree)- }+ familyTree &+ people . at n .~ Nothing &+ families %~ IM.map (+ \fam -> fam &+ head1 %~ (id & resultAt (Just $ PersonID n) .~ Nothing) &+ head2 %~ (id & resultAt (Just $ PersonID n) .~ Nothing) &+ children . contains n .~ False+ ) &+ events %~ IM.map (eventAttendees . contains n .~ False) -- | Deletes a family from the family tree, removing all references to it. deleteFamily :: FamilyID -> FamilyTree -> FamilyTree-deleteFamily (FamilyID n) familyTree =- familyTree- {families = IM.delete n $ families familyTree}+deleteFamily (FamilyID n) = families . at n .~ Nothing -- | Deletes an event from the family tree, removing all references to it. deleteEvent :: EventID -> FamilyTree -> FamilyTree deleteEvent (EventID n) familyTree =- let relevantPeople = eventAttendees (events familyTree IM.! n)+ let relevantPeople = _eventAttendees (_events familyTree IM.! n) in familyTree- {events = IM.delete n $ events familyTree- ,people = IS.foldr (IM.adjust- (\p -> p {attendedEvents = IS.delete n $ attendedEvents p}))- (people familyTree) relevantPeople+ {_events = IM.delete n $ _events familyTree+ ,_people = IS.foldr (IM.adjust+ (\p -> p {_attendedEvents = IS.delete n $ _attendedEvents p}))+ (_people familyTree) relevantPeople } -- | Creates a new tree with a given name. newTree :: Text -> FamilyTree newTree n = FamilyTree- {treeName = n- ,people = IM.empty- ,families = IM.empty- ,events = IM.empty+ {_treeName = n+ ,_people = IM.empty+ ,_families = IM.empty+ ,_events = IM.empty }++