summaryrefslogtreecommitdiff
path: root/src/LambdaCube/GL
diff options
context:
space:
mode:
authorCsaba Hruska <csaba.hruska@gmail.com>2016-02-14 02:16:09 +0100
committerCsaba Hruska <csaba.hruska@gmail.com>2016-02-14 02:16:09 +0100
commite8a7d3899f2494b20ad6c90bedea71a8ddcb3ff1 (patch)
tree5adacb129895aa0200eb5ec7e3fd42739b1734de /src/LambdaCube/GL
parent8e20bf8f814f22b7de0cba325e87e381f3e32a28 (diff)
minor cleanup
Diffstat (limited to 'src/LambdaCube/GL')
-rw-r--r--src/LambdaCube/GL/Backend.hs38
1 files changed, 17 insertions, 21 deletions
diff --git a/src/LambdaCube/GL/Backend.hs b/src/LambdaCube/GL/Backend.hs
index 1d910a2..478dfd1 100644
--- a/src/LambdaCube/GL/Backend.hs
+++ b/src/LambdaCube/GL/Backend.hs
@@ -1,4 +1,4 @@
1{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards #-} 1{-# LANGUAGE TupleSections, MonadComprehensions, RecordWildCards, LambdaCase #-}
2module LambdaCube.GL.Backend where 2module LambdaCube.GL.Backend where
3 3
4import Control.Applicative 4import Control.Applicative
@@ -559,7 +559,7 @@ setStorage :: GLRenderer -> GLStorage -> IO (Maybe String)
559setStorage p input' = setStorage' p (Just input') 559setStorage p input' = setStorage' p (Just input')
560 560
561setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String) 561setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String)
562setStorage' p input' = do 562setStorage' p@GLRenderer{..} input' = do
563 -- TODO: check matching input schema 563 -- TODO: check matching input schema
564 {- 564 {-
565 case input' of 565 case input' of
@@ -571,19 +571,15 @@ setStorage' p input' = do
571 - remove pipeline's object commands from used objectArrays 571 - remove pipeline's object commands from used objectArrays
572 - remove pipeline from attached pipelines vector 572 - remove pipeline from attached pipelines vector
573 -} 573 -}
574 ic' <- readIORef $ glInput p 574 readIORef glInput >>= \case
575 case ic' of
576 Nothing -> return () 575 Nothing -> return ()
577 Just ic -> do 576 Just InputConnection{..} -> do
578 let idx = icId ic 577 let slotRefs = slotVector icInput
579 oldInput = icInput ic 578 modifyIORef (pipelines icInput) $ \v -> v // [(icId,Nothing)]
580 slotMask = icSlotMapPipelineToInput ic 579 V.forM_ icSlotMapPipelineToInput $ \slotIdx -> do
581 slotRefs = slotVector oldInput
582 modifyIORef (pipelines oldInput) $ \v -> v // [(idx,Nothing)]
583 V.forM_ slotMask $ \slotIdx -> do
584 slot <- readIORef (slotRefs ! slotIdx) 580 slot <- readIORef (slotRefs ! slotIdx)
585 forM_ (IM.elems $ objectMap slot) $ \obj -> do 581 forM_ (IM.elems $ objectMap slot) $ \obj -> do
586 modifyIORef (objCommands obj) $ \v -> v // [(idx,V.empty)] 582 modifyIORef (objCommands obj) $ \v -> v // [(icId,V.empty)]
587 {- 583 {-
588 addition: 584 addition:
589 - get an id from pipeline input 585 - get an id from pipeline input
@@ -592,7 +588,7 @@ setStorage' p input' = do
592 - update used objectArrays, and generate object commands for objects in the related objectArrays 588 - update used objectArrays, and generate object commands for objects in the related objectArrays
593 -} 589 -}
594 case input' of 590 case input' of
595 Nothing -> writeIORef (glInput p) Nothing >> return Nothing 591 Nothing -> writeIORef glInput Nothing >> return Nothing
596 Just input -> do 592 Just input -> do
597 let pipelinesRef = pipelines input 593 let pipelinesRef = pipelines input
598 oldPipelineV <- readIORef pipelinesRef 594 oldPipelineV <- readIORef pipelinesRef
@@ -607,9 +603,9 @@ setStorage' p input' = do
607 return (i,Nothing) 603 return (i,Nothing)
608 -- create input connection 604 -- create input connection
609 let sm = slotMap input 605 let sm = slotMap input
610 pToI = [i | n <- glSlotNames p, let Just i = Map.lookup n sm] 606 pToI = [i | n <- glSlotNames, let Just i = Map.lookup n sm]
611 iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI) 607 iToP = V.update (V.replicate (Map.size sm) Nothing) (V.imap (\i v -> (v, Just i)) pToI)
612 writeIORef (glInput p) $ Just $ InputConnection idx input pToI iToP 608 writeIORef glInput $ Just $ InputConnection idx input pToI iToP
613 609
614 -- generate object commands for related objectArrays 610 -- generate object commands for related objectArrays
615 {- 611 {-
@@ -620,21 +616,21 @@ setStorage' p input' = do
620 generate object commands 616 generate object commands
621 -} 617 -}
622 let slotV = slotVector input 618 let slotV = slotVector input
623 progV = glPrograms p 619 progV = glPrograms
624 texUnitMap = glTexUnitMapping p 620 --texUnitMap = glTexUnitMapping p
625 topUnis = uniformSetup input 621 topUnis = uniformSetup input
626 emptyV = V.replicate (V.length progV) [] 622 emptyV = V.replicate (V.length progV) []
627 extend v = case shouldExtend of 623 extend v = case shouldExtend of
628 Nothing -> v 624 Nothing -> v
629 Just l -> V.concat [v,V.replicate l V.empty] 625 Just l -> V.concat [v,V.replicate l V.empty]
630 V.forM_ (V.zip pToI (glSlotPrograms p)) $ \(slotIdx,prgs) -> do 626 V.forM_ (V.zip pToI glSlotPrograms) $ \(slotIdx,prgs) -> do
631 slot <- readIORef $ slotV ! slotIdx 627 slot <- readIORef $ slotV ! slotIdx
632 forM_ (IM.elems $ objectMap slot) $ \obj -> do 628 forM_ (IM.elems $ objectMap slot) $ \obj -> do
633 let cmdV = emptyV // [(prgIdx,createObjectCommands texUnitMap topUnis obj (progV ! prgIdx)) | prgIdx <- prgs] 629 let cmdV = emptyV // [(prgIdx,createObjectCommands glTexUnitMapping topUnis obj (progV ! prgIdx)) | prgIdx <- prgs]
634 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)] 630 modifyIORef (objCommands obj) $ \v -> extend v // [(idx,cmdV)]
635 -- generate stream commands 631 -- generate stream commands
636 V.forM_ (glStreams p) $ \s -> do 632 V.forM_ glStreams $ \s -> do
637 writeIORef (glStreamCommands s) $ createStreamCommands texUnitMap topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s) 633 writeIORef (glStreamCommands s) $ createStreamCommands glTexUnitMapping topUnis (glStreamAttributes s) (glStreamPrimitive s) (progV ! glStreamProgram s)
638 return Nothing 634 return Nothing
639{- 635{-
640 track state: 636 track state: