Added Spear.IDStore

3 files changed, 123 insertions, 16 deletions

diff --git a/Spear.cabal b/Spear.cabal
index ccbf846..c683c09 100644
--- a/Spear.cabal
+++ b/Spear.cabal
@@ -16,19 +16,19 @@ 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.Physics.Types Spear.Physics.World Spear.App
-                     Spear.App.Application Spear.App.Input Spear.Assets.Image
-                     Spear.Assets.Model Spear.Collision Spear.Collision.AABB
-                     Spear.Collision.Collision Spear.Collision.Collisioner
-                     Spear.Collision.Sphere Spear.Collision.Triangle
-                     Spear.Collision.Types Spear.Game Spear.GLSL Spear.GLSL.Buffer
-                     Spear.GLSL.Error Spear.GLSL.Management Spear.GLSL.Texture
-                     Spear.GLSL.Uniform Spear.GLSL.VAO Spear.Math.Camera
-                     Spear.Math.Entity Spear.Math.Matrix3 Spear.Math.Matrix4
-                     Spear.Math.MatrixUtils Spear.Math.Octree Spear.Math.Plane
-                     Spear.Math.Quaternion Spear.Math.Spatial Spear.Math.Vector3
-                     Spear.Math.Vector4 Spear.Physics Spear.Physics.Rigid
-                     Spear.Render.AnimatedModel
+    exposed-modules: Spear.IDStore 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 Spear.Collision.Collision
+                     Spear.Collision.Collisioner Spear.Collision.Sphere
+                     Spear.Collision.Triangle Spear.Collision.Types Spear.Game
+                     Spear.GLSL Spear.GLSL.Buffer Spear.GLSL.Error Spear.GLSL.Management
+                     Spear.GLSL.Texture Spear.GLSL.Uniform Spear.GLSL.VAO
+                     Spear.Math.Camera Spear.Math.Entity Spear.Math.Matrix3
+                     Spear.Math.Matrix4 Spear.Math.MatrixUtils Spear.Math.Octree
+                     Spear.Math.Plane Spear.Math.Quaternion Spear.Math.Spatial
+                     Spear.Math.Vector3 Spear.Math.Vector4 Spear.Physics
+                     Spear.Physics.Rigid Spear.Render.AnimatedModel
                      Spear.Render.Material Spear.Render.Model Spear.Render.Program
                      Spear.Render.Renderable Spear.Render.StaticModel
                      Spear.Render.Texture Spear.Scene.Graph Spear.Scene.Light
@@ -56,4 +56,4 @@ library
                   Spear/Sys
     hs-source-dirs: .
     ghc-options: -O2 -rtsopts
- 
+ 
\ No newline at end of file
diff --git a/Spear.lkshw b/Spear.lkshw
index c76f434..ef77439 100644
--- a/Spear.lkshw
+++ b/Spear.lkshw
@@ -1,10 +1,10 @@
 Version of workspace file format:
                1
 Time of storage:
-               "Tue Aug  7 23:05:20 CEST 2012"
+               "Wed Aug  8 12:06:13 CEST 2012"
 Name of the workspace:
                "Spear"
 File paths of contained packages:
                ["demos/simple-scene/simple-scene.cabal","Spear.cabal"]
 Maybe file path of an active package:
-               Just "demos/simple-scene/simple-scene.cabal"
\ No newline at end of file
+               Just "Spear.cabal"
\ No newline at end of file
diff --git a/Spear/IDStore.hs b/Spear/IDStore.hs
new file mode 100644
index 0000000..9762438
--- /dev/null
+++ b/Spear/IDStore.hs
@@ -0,0 +1,107 @@
+module Spear.IDStore
+(
+    ID   
+,   IDStore
+,   emptyIDStore
+,   newID
+,   freeID
+)
+where
+
+
+import Data.Vector.Unboxed as U
+import Control.Monad.State -- test
+import Text.Printf -- test
+import Debug.Trace
+
+
+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')