module Graphics.ChalkBoard.CBIR where import Foreign.Ptr (Ptr) import Foreign.C.Types (CUChar) import Data.Word import Graphics.ChalkBoard.Types (UI,RGB(..),RGBA(..)) import Data.Array.Unboxed import Data.Array.MArray import Data.Array.Storable import Graphics.ChalkBoard.IStorable as IS import Graphics.ChalkBoard.Core import Data.Binary import Control.Monad {-What do we need? * A way of creating a canvas * The canvas has size, pixels, depth, RGB/BW, opt alpha, perhaps 1-bit array. * We have ways of placing slices (rectangles?) of these canvases onto the 'screen'. Difference places, sizes, rotations. * Ways drawing these to a canvas * Ways of importing and exporting canvases -} type BufferId = Int -- make abstact later type CBIR = ([Inst CBBO],CBBO) -- A list of instructions, and a Buffer to render -- ChalkBoardBufferObject newtype CBBO = CBBO Int -- unique 'label' or tag for each named thing. deriving (Eq,Ord) instance Show CBBO where show (CBBO n) = "_" ++ show n data Depth = BitDepth -- 1 bit per pixel | G8BitDepth -- 8 bits per pixel (grey) | RGB24Depth -- (R,G,B), 8 bits per pixel | RGBADepth -- (R,G,B,A), 8 bits per pixel deriving Show -- In a sense, the Depth is the type of our CBBO. -- KM: I would say leave as 0-1 since that's what OpenGL defaults to anyway for colors. Plus then if you want to use it for something else like you did with PointMap?, you can. data Background = BackgroundBit Bool {- AG: does a pixel mean later 'draw this *color* (white/black), or draw this pixel *if* black? KM: I would say the "draw this pixel if true" approach might be faster? Then could use the 8Bit version if you want to force it to draw all pixels? -} | BackgroundG8Bit UI -- this may have the same issue? | BackgroundRGB24Depth RGB | BackgroundRGBADepth RGBA | BackgroundArr (IStorableArray (Int,Int,Int)) instance Show Background where show (BackgroundBit b) = "(BackgroundBit $ " ++ show b ++ ")" show (BackgroundG8Bit g) = "(BackgroundG8Bit $ " ++ show g ++ ")" show (BackgroundRGB24Depth c) = "(BackgrounddRGB24Depth $ " ++ show c ++ ")" show (BackgroundRGBADepth c) = "(BackgroundRGBADepth $ " ++ show c ++ ")" show (BackgroundArr {}) = "(BackgroundArr undefined)" -- type RGBA = (UI,UI,UI,UI) type UIPoint = (UI,UI) -- A mapping from a point on the source CBBO to a corresponding point on the canvas CBBO. data PointMap = PointMap UIPoint UIPoint deriving Show -- Telling CopyBoard whether to use the source alpha or the destination alpha (use source for a /complete/ copy) data WithAlpha = WithSrcAlpha | WithDestAlpha deriving Show -- AG: The depth is determined by the Background, we only need one! -- We now use Inst var, but use Inst CBBO in most cases. data Inst var = Allocate var -- tag for this ChalkBoardBufferObject (Int,Int) -- size of ChalkBoardBufferObject Depth -- depth of buffer Background -- what to draw at allocation -- ^ This means allocate a buffer, n * m pixels, with a specific depth, and a background (default) color. {- AG: other considerations include * Do we project into it using 0..1 x 0..1? (say yes for now) (KM: Sounds fine as a first approach. Could support both exact position and percentage (0-1) eventually.) * Does it loop round, when viewed? (KM: I would say not when printed onto the screen, at least. Maybe internally for 'from' CBBOs doing splats, but the 'to' board probably won't want it to wrap, just be off the edge.) -} --- Everything can be written as triangles (for now)! | SplatTriangle var -- to write from (may be a color, but will be allocated) var -- to write to PointMap PointMap PointMap | SplatPolygon var var [PointMap] | SplatColor RGBA --Should probably make a color type or something? var Bool -- do you do alpha blending (True), or just copy bits (False) [UIPoint] {- | SplatWholeBoardColor RGBA var -} | SplatBuffer var -- src var -- dest | CopyBuffer WithAlpha var -- src var -- dest | AllocateImage var FilePath | SaveImage var FilePath | Delete var -- | ScaleAlpha var UI -- LATER | Nested String [Inst var] | Exit deriving Show copyBoard :: var -> var -> Inst var copyBoard src target = CopyBuffer WithSrcAlpha src target colorBoard :: RGB -> var -> Inst var colorBoard (RGB r g b) target = SplatColor (RGBA r g b 1) target False [ p | p <- [(0,0),(0,1),(1,1),(1,0)]] {- AG: Questions and considerations * Do you average each same point, inside the triangle from its neighbours, or just sample 1? (We'll test both, and see how they look.) KM: Maybe I'm interpreting the question wrong, but I would think you just take each _vertex_ color (1 point sample) and then have OpenGL do blending later? (texture maps would be special splats) AG: I think we'll want both. I think of splat as cutting out a piece of the source CBBO, and pasting it onto the dest CBBO. * How do we introduce alpha, here? Is it always a property of the source CBBO, or it there other places we can determine this. KM: I would say source alpha. If you want something to cover completely, you leave source alpha as one. If you want it to be partly transparent, you change the source alpha beforehand? * Also, we should still support rectangles primitively? KM: Right, and we technically only need both corners as input for this (you mean rectangle splatting right?) Might also want primitive support for lines at least, and since it's designed for presentations, we could have primitive circles/ellipses/text/(arrows?) as well if we want. At least, I think that calculating things like ellipse->triangles would probably be faster in OpenGL/C if we can get it pushed down that far. -} {- Other Considerations ΒΆ * How do we allocate (or load from a structure) a pre-existing image? Is this done at create time only, or do we want to update a CBBO? * I'm not sure about the defaults, vs the loading of an 'image'. Both are sorts of assignment/update, as is loading from a file. example1 = alloc (2,2) Bit [[ 0, 1 ], [ 1, 0 ]] example2 = alloc (2,2) Bit [[0]] example3 = alloc (2,2) Bit "foo.ppm" -} showCBIRs :: Show i => [Inst i] -> String showCBIRs insts = concat [ prespace " " ([ch] ++ " " ++ show' inst) | (ch,inst) <- zip ('[':repeat ',') insts ] ++ " ]\n" where show' (Nested msg []) = "Nested " ++ show msg ++ "[]" show' (Nested msg insts') = "Nested " ++ show msg ++ "\n" ++ prespace " " (showCBIRs insts') show' other = show other prespace c = unlines . map (\ m -> c ++ m) . lines instance Binary PointMap where put (PointMap a b) = put a >> put b get = liftM2 PointMap get get instance Binary WithAlpha where put WithSrcAlpha = put (0 :: Word8) put WithDestAlpha = put (1 :: Word8) get = do tag <- getWord8 case tag of 0 -> return $ WithSrcAlpha 1 -> return $ WithDestAlpha instance Binary Depth where put BitDepth = put (0 :: Word8) put G8BitDepth = put (1 :: Word8) put RGB24Depth = put (2 :: Word8) put RGBADepth = put (3 :: Word8) get = do tag <- getWord8 case tag of 0 -> return $ BitDepth 1 -> return $ G8BitDepth 2 -> return $ RGB24Depth 3 -> return $ RGBADepth {- data Background = BackgroundBit Bool {- AG: does a pixel mean later 'draw this *color* (white/black), or draw this pixel *if* black? KM: I would say the "draw this pixel if true" approach might be faster? Then could use the 8Bit version if you want to force it to draw all pixels? -} | BackgroundG8Bit UI -- this may have the same issue? | BackgroundRGB24Depth UI UI UI | BackgroundRGBADepth UI UI UI UI | BackgroundPtr (Ptr CUChar) -- the way to interpretate this depends on the Depth field. | BackgroundArr (IStorableArray (Int,Int,Int)) -} instance Binary Background where put (BackgroundBit b) = put (0 :: Word8) >> put b put (BackgroundG8Bit g) = put (1 :: Word8) >> put g put (BackgroundRGB24Depth rgb) = put (2 :: Word8) >> put rgb put (BackgroundRGBADepth rgba) = put (3 :: Word8) >> put rgba put (BackgroundArr arr) = put (4 :: Word8) >> put arr get = do tag <- getWord8 case tag of 0 -> liftM BackgroundBit get 1 -> liftM BackgroundG8Bit get 2 -> liftM BackgroundRGB24Depth get 3 -> liftM BackgroundRGBADepth get 4 -> liftM BackgroundArr get instance Binary var => Binary (Inst var) where put (Allocate v sz d b) = put (0 :: Word8) >> put v >> put sz >> put d >> put b put (SplatTriangle v1 v2 p1 p2 p3) = put (1 :: Word8) >> put v1 >> put v2 >> put p1 >> put p2 >> put p3 put (SplatPolygon v1 v2 ps) = put (2 :: Word8) >> put v1 >> put v2 >> put ps put (SplatColor rgba v a ps) = put (3 :: Word8) >> put rgba >> put v >> put a >> put ps put (SplatBuffer src dst) = put (4 :: Word8) >> put src >> put dst put (CopyBuffer wa src dst) = put (5 :: Word8) >> put wa >> put src >> put dst put (AllocateImage rgba v) = error "AllocateImage" put (SaveImage v nm) = put (7 :: Word8) >> put v >> put nm put (Delete v) = put (8 :: Word8) >> put v put (Nested nm insts) = put (9 :: Word8) >> put nm >> put insts put (Exit) = put (10 :: Word8) get = do tag <- getWord8 case tag of 0 -> liftM4 Allocate get get get get 1 -> liftM5 SplatTriangle get get get get get 2 -> liftM3 SplatPolygon get get get 3 -> liftM4 SplatColor get get get get 4 -> liftM2 SplatBuffer get get 5 -> liftM3 CopyBuffer get get get 6 -> error "AllocateImage" 7 -> liftM2 SaveImage get get 8 -> liftM Delete get 9 -> liftM2 Nested get get 10 -> return $ Exit