From ad2c98ba8a1380baad5b648acb2c2b7f7c474101 Mon Sep 17 00:00:00 2001 From: Marc Sunet Date: Wed, 8 Aug 2012 21:15:41 +0200 Subject: Moved IDStore to Store.ID. Created generic Store --- Spear.cabal | 3 +- Spear.lkshs | 12 +++--- Spear.lkshw | 2 +- Spear/IDStore.hs | 106 ---------------------------------------------- Spear/Sys/Store.hs | 114 ++++++++++++++++++++++++++++++++++++++++++++++++++ Spear/Sys/Store/ID.hs | 106 ++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 229 insertions(+), 114 deletions(-) delete mode 100644 Spear/IDStore.hs create mode 100644 Spear/Sys/Store.hs create mode 100644 Spear/Sys/Store/ID.hs diff --git a/Spear.cabal b/Spear.cabal index f025de2..d30cbae 100644 --- a/Spear.cabal +++ b/Spear.cabal @@ -16,7 +16,7 @@ library StateVar -any, base -any, bytestring -any, directory -any, mtl -any, transformers -any, resource-simple -any, parsec >=3.1.3, containers -any, vector -any, array -any - exposed-modules: Spear.Math.Triangle Spear.IDStore + exposed-modules: Spear.Math.Triangle Spear.Physics.Types Spear.Physics.World Spear.App Spear.App.Application Spear.App.Input Spear.Assets.Image Spear.Assets.Model Spear.Collision Spear.Collision.AABB @@ -34,6 +34,7 @@ library Spear.Render.StaticModel Spear.Render.Texture Spear.Scene.Graph Spear.Scene.Light Spear.Scene.Loader Spear.Scene.Scene Spear.Scene.SceneResources Spear.Setup Spear.Sys.Timer + Spear.Sys.Store Spear.Sys.Store.ID Spear.Updatable exposed: True buildable: True diff --git a/Spear.lkshs b/Spear.lkshs index a3f492f..042ccc8 100644 --- a/Spear.lkshs +++ b/Spear.lkshs @@ -1,18 +1,18 @@ Version of session file format: 1 Time of storage: - "Wed Aug 8 13:25:10 CEST 2012" -Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 1, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 273) 205)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 716) 954 -Population: [(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameObject.hs" 3129)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/IDStore.hs" 186)),[SplitP LeftP]),(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 286 (PackageScope False,False) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([[5]],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics.hs" 207)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/Rigid.hs" 2175)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Math/Spatial.hs" 0)),[SplitP LeftP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/World.hs" 3781)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 1603)),[SplitP LeftP])] + "Wed Aug 8 20:32:17 CEST 2012" +Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 4, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 267) 200)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 702) 954 +Population: [(Just (ErrorsSt ErrorsState),[SplitP RightP,SplitP TopP]),(Just (FilesSt FilesState),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameObject.hs" 8164)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/GameState.hs" 670)),[SplitP LeftP]),(Just (InfoSt (InfoState (Just (Real (RealDescr {dscName' = "UpdateGO", dscMbTypeStr' = Just "type UpdateGO =\n Bool -> Input -> Float -> State [GameMessage] GameObject", dscMbModu' = Just (PM {pack = PackageIdentifier {pkgName = PackageName "simple-scene", pkgVersion = Version {versionBranch = [0,1,0,0], versionTags = []}}, modu = ModuleName ["GameObject"]}), dscMbLocation' = Just (Location {locationSLine = 43, locationSCol = 1, locationELine = 43, locationECol = 73}), dscMbComment' = Nothing, dscTypeHint' = TypeDescr, dscExported' = False}))))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 328 (PackageScope False,False) (Just (ModuleName ["Spear","IDStore"]),Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([[0]],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([[5]],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics.hs" 207)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/Rigid.hs" 2175)),[SplitP LeftP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/Spear/Physics/World.hs" 1269)),[SplitP LeftP]),(Just (BufferSt (BufferState "/home/jeanne/programming/haskell/Spear/demos/simple-scene/main.hs" 1294)),[SplitP LeftP])] Window size: (1841,964) Completion size: (750,400) Workspace: Just "/home/jeanne/programming/haskell/Spear/Spear.lkshw" -Active pane: Just "IDStore.hs" +Active pane: Just "Modules" Toolbar visible: True -FindbarState: (False,FindState {entryStr = "asd", entryHist = ["gravity","asdad","rotSpeed","azimuth","mandatory","mandao","col","forward","MouseButton"], replaceStr = "mandatory'", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) +FindbarState: (False,FindState {entryStr = "asd", entryHist = ["Triangle","transforma","gravity","asdad","rotSpeed","azimuth","mandatory","mandao","col","forward","MouseButton"], replaceStr = "CTriangle", replaceHist = [], caseSensitive = True, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) Recently opened files: - ["/home/jeanne/programming/haskell/Spear/demos/simple-scene/Spear/IDStore.hs","/home/jeanne/programming/haskell/Spear/Spear/Physics/Types.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collisioner.hs","/home/jeanne/programming/haskell/Spear/Spear/App/Input.hs"] + ["/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.h","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model.hsc","/home/jeanne/programming/haskell/Spear/Spear/Math/Spatial.hs","/home/jeanne/programming/haskell/Spear/Spear/Math/Triangle.hs","/home/jeanne/programming/haskell/Spear/Spear/Render/Triangle.hs","/home/jeanne/programming/haskell/Spear/Spear/Assets/Model/Model.c","/home/jeanne/programming/haskell/Spear/Spear/Scene/Loader.hs","/home/jeanne/programming/haskell/Spear/Spear/IDStore.hs","/home/jeanne/programming/haskell/Spear/demos/simple-scene/Spear/IDStore.hs","/home/jeanne/programming/haskell/Spear/Spear/Physics/Types.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collision.hs","/home/jeanne/programming/haskell/Spear/Spear/Collision/Collisioner.hs"] Recently opened workspaces: ["/home/jeanne/leksah.lkshw"] \ No newline at end of file diff --git a/Spear.lkshw b/Spear.lkshw index cc572e4..2291729 100644 --- a/Spear.lkshw +++ b/Spear.lkshw @@ -1,7 +1,7 @@ Version of workspace file format: 1 Time of storage: - "Wed Aug 8 15:15:08 CEST 2012" + "Wed Aug 8 21:04:06 CEST 2012" Name of the workspace: "Spear" File paths of contained packages: diff --git a/Spear/IDStore.hs b/Spear/IDStore.hs deleted file mode 100644 index 8879756..0000000 --- a/Spear/IDStore.hs +++ /dev/null @@ -1,106 +0,0 @@ -module Spear.IDStore -( - ID -, IDStore -, emptyIDStore -, newID -, freeID -) -where - - -import Data.Vector.Unboxed as U -import Control.Monad.State -- test -import Text.Printf -- test - - -type ID = Int - - -data IDStore = IDStore - { assigned :: Vector Bool -- ^ A bit array indicating used IDs. - , last :: Int -- ^ The greatest ID assigned so far. - } - deriving Show - - --- | Create an empty ID store. -emptyIDStore :: IDStore -emptyIDStore = IDStore U.empty (-1) - - --- | Request an ID from the ID store. -newID :: IDStore -> (ID, IDStore) -newID store@(IDStore assigned last) = - if last == U.length assigned - 1 - then case findIndex (==False) assigned of - Just i -> assign i store - Nothing -> newID $ IDStore (assigned U.++ U.replicate (max 1 last + 1) False) last - else - assign (last+1) store - - --- Assign the given ID in the ID store. -assign :: ID -> IDStore -> (ID, IDStore) -assign i (IDStore assigned last) = - let assigned' = assigned // [(i,True)] - in (i, IDStore assigned' (max last i)) - - --- | Free the given ID from the ID store. -freeID :: ID -> IDStore -> IDStore -freeID i (IDStore assigned last) = - let assigned' = assigned // [(i,False)] - in if i == last - then case findLastIndex (==True) assigned' of - Just j -> IDStore assigned' j - Nothing -> IDStore assigned' 0 - else - IDStore assigned' last - - -findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int -findLastIndex p v = findLastIndex' p v Nothing 0 - where - findLastIndex' p v current i = - if i >= U.length v then current - else if p $ v U.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) - else findLastIndex' p v current (i+1) - - --- test -test :: IO () -test = evalStateT test' emptyIDStore - - -test' :: StateT IDStore IO () -test' = do - x <- request - y <- request - z <- request - w <- request - free y - request - free w - request - a <- request - free a - request - return () - - -request :: StateT IDStore IO ID -request = do - store <- get - let (i, store') = newID store - put store' - lift $ printf "ID requested, got %d; %s\n" i (show store') - return i - - -free :: ID -> StateT IDStore IO () -free i = do - store <- get - let store' = freeID i store - put store' - lift $ printf "ID %d freed; %s\n" i (show store') diff --git a/Spear/Sys/Store.hs b/Spear/Sys/Store.hs new file mode 100644 index 0000000..3d5d794 --- /dev/null +++ b/Spear/Sys/Store.hs @@ -0,0 +1,114 @@ +module Spear.Sys.Store +( + Store +, Index +, emptyStore +, store +, storeFree +, element +) +where + + +import Data.Maybe (isJust, isNothing) +import Data.Vector as V +import Control.Monad.State -- test +import Text.Printf -- test + + +type Index = Int + + +data Store a = Store + { assigned :: Vector (Maybe a) -- ^ An array of objects. + , last :: Index -- ^ The greatest index assigned so far. + } + deriving Show + + +-- | Create an empty store. +emptyStore :: Store a +emptyStore = Store V.empty (-1) + + +-- | Store the given element in the store. +store :: a -> Store a -> (Index, Store a) +store elem s@(Store assigned last) = + if last == V.length assigned - 1 + then case findIndex isNothing assigned of + Just i -> assign i elem s + Nothing -> store elem $ Store (assigned V.++ V.replicate (max 1 last + 1) Nothing) last + else + assign (last+1) elem s + + +-- Assign a slot the given element in the store. +assign :: Index -> a -> Store a -> (Index, Store a) +assign i elem (Store assigned last) = + let assigned' = assigned // [(i,Just elem)] + in (i, Store assigned' (max last i)) + + +-- | Free the given element from the store. +storeFree :: Index -> Store a -> Store a +storeFree i (Store assigned last) = + let assigned' = assigned // [(i,Nothing)] + in if i == last + then case findLastIndex isJust assigned' of + Just j -> Store assigned' j + Nothing -> Store assigned' 0 + else + Store assigned' last + + +findLastIndex :: (a -> Bool) -> Vector a -> Maybe Index +findLastIndex p v = findLastIndex' p v Nothing 0 + where + findLastIndex' p v current i = + if i >= V.length v then current + else if p $ v V.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) + else findLastIndex' p v current (i+1) + + +-- | Access the element in the given slot. +element :: Index -> Store a -> Maybe a +element index (Store assigned _) = assigned V.! index + + +-- test +test :: IO () +test = evalStateT test' emptyStore + + +test' :: StateT (Store Int) IO () +test' = do + x <- store' 1 + y <- store' 2 + z <- store' 3 + w <- store' 4 + free y + store' 5 + free w + store' 6 + a <- store' 7 + free a + store' 8 + return () + + +store' :: Int -> StateT (Store Int) IO Int +store' elem = do + s <- get + let (i, s') = store elem s + put s' + lift $ printf "%d stored at %d; %s\n" elem i (show s') + return i + + +free :: Index -> StateT (Store Int) IO () +free i = do + s <- get + let s' = storeFree i s + put s' + lift $ printf "Slot %d freed; %s\n" i (show s') + diff --git a/Spear/Sys/Store/ID.hs b/Spear/Sys/Store/ID.hs new file mode 100644 index 0000000..a4da3d0 --- /dev/null +++ b/Spear/Sys/Store/ID.hs @@ -0,0 +1,106 @@ +module Spear.Sys.Store.ID +( + ID +, IDStore +, emptyIDStore +, newID +, freeID +) +where + + +import Data.Vector.Unboxed as U +import Control.Monad.State -- test +import Text.Printf -- test + + +type ID = Int + + +data IDStore = IDStore + { assigned :: Vector Bool -- ^ A bit array indicating used IDs. + , last :: Int -- ^ The greatest ID assigned so far. + } + deriving Show + + +-- | Create an empty ID store. +emptyIDStore :: IDStore +emptyIDStore = IDStore U.empty (-1) + + +-- | Request an ID from the ID store. +newID :: IDStore -> (ID, IDStore) +newID store@(IDStore assigned last) = + if last == U.length assigned - 1 + then case findIndex (==False) assigned of + Just i -> assign i store + Nothing -> newID $ IDStore (assigned U.++ U.replicate (max 1 last + 1) False) last + else + assign (last+1) store + + +-- Assign the given ID in the ID store. +assign :: ID -> IDStore -> (ID, IDStore) +assign i (IDStore assigned last) = + let assigned' = assigned // [(i,True)] + in (i, IDStore assigned' (max last i)) + + +-- | Free the given ID from the ID store. +freeID :: ID -> IDStore -> IDStore +freeID i (IDStore assigned last) = + let assigned' = assigned // [(i,False)] + in if i == last + then case findLastIndex (==True) assigned' of + Just j -> IDStore assigned' j + Nothing -> IDStore assigned' 0 + else + IDStore assigned' last + + +findLastIndex :: Unbox a => (a -> Bool) -> Vector a -> Maybe Int +findLastIndex p v = findLastIndex' p v Nothing 0 + where + findLastIndex' p v current i = + if i >= U.length v then current + else if p $ v U.! i then let x = Just i in x `seq` findLastIndex' p v x (i+1) + else findLastIndex' p v current (i+1) + + +-- test +test :: IO () +test = evalStateT test' emptyIDStore + + +test' :: StateT IDStore IO () +test' = do + x <- request + y <- request + z <- request + w <- request + free y + request + free w + request + a <- request + free a + request + return () + + +request :: StateT IDStore IO ID +request = do + store <- get + let (i, store') = newID store + put store' + lift $ printf "ID requested, got %d; %s\n" i (show store') + return i + + +free :: ID -> StateT IDStore IO () +free i = do + store <- get + let store' = freeID i store + put store' + lift $ printf "ID %d freed; %s\n" i (show store') -- cgit v1.2.3