diff options
-rw-r--r-- | src/LambdaCube/GL/Backend.hs | 38 |
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 #-} |
2 | module LambdaCube.GL.Backend where | 2 | module LambdaCube.GL.Backend where |
3 | 3 | ||
4 | import Control.Applicative | 4 | import Control.Applicative |
@@ -559,7 +559,7 @@ setStorage :: GLRenderer -> GLStorage -> IO (Maybe String) | |||
559 | setStorage p input' = setStorage' p (Just input') | 559 | setStorage p input' = setStorage' p (Just input') |
560 | 560 | ||
561 | setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String) | 561 | setStorage' :: GLRenderer -> Maybe GLStorage -> IO (Maybe String) |
562 | setStorage' p input' = do | 562 | setStorage' 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: |