Prop reification/splitting

2022-07-24 13:45:05 +01:00
parent 5a2f529182
commit ac069d08f6
31 changed files with 585 additions and 458 deletions
@@ -0,0 +1,87 @@
+module Dodge.Prop.Draw
+    where
+import Geometry.Polygon
+import Geometry.Data
+import Dodge.Data.Prop
+import ShapePicture
+import Shape
+import Picture
+import qualified Quaternion as Q
+
+drawProp' :: Prop -> SPic
+drawProp' pr = drawProp (_prDraw pr) pr
+
+drawProp :: PropDraw -> Prop -> SPic
+drawProp pd = case pd of
+    PropDrawSPic spic -> const spic
+    PropDrawMovingShape pd' -> \pr -> drawMovingShape pr (fst $ drawProp pd' pr)
+    PropDrawMovingShapeCol sh -> \pr -> drawMovingShapeCol pr sh
+    PropDoubleLampCover h -> drawDoubleLampCover h
+    PropVerticalLampCover h -> drawVerticalLampCover h
+    PropLampCover h -> drawLampCover h
+    PropDrawToggle pd' -> propDrawToggle pd'
+    PropDrawGib x -> noPic . drawGib x
+    PropDrawFlatTranslate x -> \pr 
+        -> uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr
+
+drawGib :: Float -> Prop -> Shape
+drawGib x pr = flesh <> skin
+  where
+    flesh = colorSH (dark $ dark red)
+        . translateSHz (negate x)
+        $ upperPrismPoly (2*x) $ square x
+    skin = colorSH (_prColor pr)
+        . translateSH (V3 1 1 (1 - x))
+        $ upperPrismPoly (2*x) $ square x
+
+propDrawToggle :: PropDraw -> Prop -> SPic
+propDrawToggle pd pr
+    | not (_prToggle pr) = mempty
+    | otherwise = drawProp pd pr
+
+drawLampCover :: Float -> Prop -> SPic
+drawLampCover h pr = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr)
+    $ rotateSH (_prRot pr) $ mconcat
+    [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
+    , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
+    , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2    (-1) 3 
+    , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2    3 
+    , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)]
+    ]
+    , mempty
+    )
+
+drawVerticalLampCover :: Float -> Prop -> SPic
+drawVerticalLampCover h pr =
+    ( translateSHz h . uncurryV translateSHf (_prPos pr) 
+        $ rotateSHx (_prRot pr) $ mconcat
+        [ 
+        translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5
+        ]
+    , mempty
+    )
+
+drawMovingShape :: Prop -> Shape -> SPic
+drawMovingShape pr = noPic
+    . translateSHz (_prPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_prQuat pr))
+
+drawMovingShapeCol :: Prop -> Shape -> SPic
+drawMovingShapeCol pr = noPic
+    . translateSHz (_prPosZ pr)
+    . uncurryV translateSHf (_prPos pr) 
+    . overPosSH (Q.rotate (_prQuat pr))
+    . colorSH (_prColor pr)
+
+drawDoubleLampCover :: Float -> Prop -> SPic
+drawDoubleLampCover h pr =
+    ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr) 
+        $ rotateSH (_prRot pr) $ mconcat
+        [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5       (-6) 6
+        , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6
+        , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5]
+        , upperPrismPoly 1 [V2 0   1 ,V2 (-6) (-5),V2 6 (-5)]
+        ]
+    , mempty
+    )