From 5e228f4f55eafdb947426bb900175eb5d8188073 Mon Sep 17 00:00:00 2001 From: Marc Sunet Date: Wed, 8 Aug 2012 13:15:55 +0200 Subject: Added Spear.IDStore --- Spear.cabal | 28 +++++++-------- Spear.lkshw | 4 +-- Spear/IDStore.hs | 107 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 123 insertions(+), 16 deletions(-) create mode 100644 Spear/IDStore.hs 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') -- cgit v1.2.3