Cache rendering results as much as possible

src/Carriage.elm

@@ -15,6 +15,7 @@ import String
 import TrackA
 import TrackA exposing (TrackA)
 import Either
+import Svg.Lazy as Svg
 
 type Direction = Upwards | Downwards
 
@@ -199,7 +200,7 @@ renderCarriageAt flags attributes (a1,p1) (a2,p2) =
         , SvgAttr.ry (toString carConfig.roundness_y)
         ]
         carConfig.carLen carConfig.carWidth car_center car_angle
-    , SvgUtils.svgCenteredText [ SvgAttr.class "carLabel" ] flags.label car_center car_angle
+    , SvgUtils.svgCenteredText [ SvgAttr.class "carLabel" ] (Debug.log "Rendering car" flags.label) car_center car_angle
     -- , SvgUtils.svgAngledPoint <| { angle = a1, p = p1 }
     -- , SvgUtils.svgAngledPoint <| { angle = a2, p = p2 }
     -- , SvgUtils.svgAngledPoint <| { angle = car_angle, p = car_center }
@@ -227,8 +228,7 @@ renderCarriageOnPath offset path attributes car =
       )
       |> Maybe.withDefault (0, {x=0, y=0})
   in
-  [ renderCarriageAt
-      car.flags attributes
+  [ renderCarriageAt car.flags attributes
       (offset2point axis1)
       (offset2point axis2)
   ]

src/RailPuzzle.elm

@@ -34,6 +34,7 @@ import Html.App
 import Svg.Attributes as SvgAttr
 import Svg
 import Svg.Events
+import Svg.Lazy as Svg
 import SvgUtils
 import AnimationFrame
 import TrackA
@@ -46,7 +47,7 @@ import Char
 import P2D
 
 -- MODEL
-type alias Model =
+type alias RawModel render_cache =
   { rt : RT.LayoutedRailTree (Has RT.Path ()) ()
   , cars : Array C.Carriage
   , initial_car_positions : Array RT.Path
@@ -60,12 +61,21 @@ type alias Model =
   , time_requested : List (Time -> Msg)
   -- wether to show the cars in the desired order
   , show_train_preview : Bool
-  , train_preview : (SvgUtils.BoundedSvg TrainPreview.EmptyType)
   , show_shunt_labels : Bool
-  , shunt_labels : List (Svg.Svg TrainPreview.EmptyType)
   , history : History
+  , render_cache : render_cache
+  }
+
+type alias RenderingCache =
+  { train_preview : (SvgUtils.BoundedSvg TrainPreview.EmptyType)
+  , shunt_labels : List (Svg.Svg TrainPreview.EmptyType)
+  , rendered_rail_tree : List (Svg.Svg Msg)
+  , bbox_rail_tree : SvgUtils.BoundingRect
   }
 
+type alias Model = RawModel RenderingCache
+
+
 -- UPDATE
 type Msg =
     RailClicked RT.Path
@@ -107,16 +117,12 @@ init car_positions rail_net =
       , time_requested = []
       , show_train_preview = True
       , query = query
-      , train_preview = TrainPreview.render cars query
       , show_shunt_labels = False
-      , shunt_labels =
-          Shunt.shunts rail_net
-          |> List.filter (not << List.isEmpty)
-          |> List.indexedMap (Shunt.view layouted_rail_net Shunt.showTrackIdx)
       , history = RPHistory.init
+      , render_cache = ()
       }
   in
-  model
+  fillRenderCache model
 
 
 getQuery : Model -> List Int
@@ -192,8 +198,8 @@ runCommandNoHistory cmd model =
     RPCmd.SetQuery query ->
       { model
       | query = query
-      , train_preview = TrainPreview.render model.cars query
       }
+      |> fillRenderCache
 
     RPCmd.Batch cmds ->
       List.foldl runCommand model cmds
@@ -367,7 +373,40 @@ isSolved model =
   |> Maybe.map correct_order
   |> Maybe.withDefault False
 
+
 -- VIEW
+
+fillRenderCache : RawModel a -> Model
+fillRenderCache model =
+  let
+    singleton x = [x]
+
+    -- the bumper at the root
+    root_bumper =
+      RT.Junction (Has.unit RT.AutoAngles) [] -- take a simple bumper
+      -- layout it at the root but with the reversed angle
+      |> RT.layoutRailTreeAt (P2D.Angled -180 (P2D.P2D 0.0 0.0))
+
+    root_bumper_svg : List (Svg.Svg Msg)
+    root_bumper_svg =
+      RT.renderRailTree TrainPreview.exfalso root_bumper
+
+  in
+  { model | render_cache =
+  { train_preview = TrainPreview.render model.cars model.query
+  , shunt_labels =
+      Shunt.shunts model.rt
+      |> List.filter (not << List.isEmpty)
+      |> List.indexedMap (Shunt.view model.rt Shunt.showTrackIdx)
+  , rendered_rail_tree =
+        RT.renderRailTree
+            (singleton << Svg.Events.onMouseUp << RailClicked << Has.witness)
+            model.rt
+        ++ root_bumper_svg
+  , bbox_rail_tree =
+      RT.boundingBox model.rt `SvgUtils.bboxUnion` RT.boundingBox root_bumper
+  }}
+
 view : Model -> Html Msg
 view model =
   let
@@ -384,17 +423,6 @@ view model =
       |> Array.indexedMap (\i c -> C.renderCarriage model.rt (car_attributes i c) c)
       |> Array.toList
       |> List.concat
-    singleton a = [a]
-    bbox =
-      let rect = RT.boundingBox model.rt
-      in
-      Svg.rect
-      [ SvgAttr.width <| toString (rect.max.x - rect.min.x)
-      , SvgAttr.height  <| toString(rect.max.y - rect.min.y)
-      , SvgAttr.x  <| toString(rect.min.x)
-      , SvgAttr.y  <| toString(rect.min.y)
-      , SvgAttr.class "boundingbox"
-      ] []
 
     -- For Debugging: show the points for bbox computation
     -- bpoints =
@@ -408,35 +436,19 @@ view model =
     --       ]
     --       [])
 
-    rendered_rail_tree =
-        RT.renderRailTree
-            (singleton << Svg.Events.onMouseUp << RailClicked << Has.witness)
-            model.rt
-    bbox_rail_tree = RT.boundingBox model.rt
-
     mapSnd f (a,b) = (a,f b)
 
     train_preview : (SvgUtils.BoundedSvg a)
     train_preview =
-      model.train_preview
+      model.render_cache.train_preview
       |> mapSnd (Html.App.map TrainPreview.exfalso)
 
     shunt_labels : List (Svg.Svg any)
     shunt_labels =
       if model.show_shunt_labels
-      then List.map (Html.App.map TrainPreview.exfalso) model.shunt_labels
+      then List.map (Html.App.map TrainPreview.exfalso) model.render_cache.shunt_labels
       else []
 
-    root_bumper : SvgUtils.BoundedSvg any
-    root_bumper =
-      RT.Junction (Has.unit RT.AutoAngles) [] -- take a simple bumper
-      -- layout it at the root but with the reversed angle
-      |> RT.layoutRailTreeAt (P2D.Angled -180 (P2D.P2D 0.0 0.0))
-      |> (\lrt ->
-           ( RT.boundingBox lrt
-           , Svg.g [] <| RT.renderRailTree TrainPreview.exfalso lrt
-           ))
-
   in
   SvgUtils.boundedSvg
     [ SvgAttr.class <|
@@ -447,7 +459,11 @@ view model =
     <| (if model.show_train_preview
         then (SvgUtils.aboveOf SvgUtils.Center 20.0 train_preview)
         else identity)
-    <| SvgUtils.union root_bumper
-    <| (bbox_rail_tree, Svg.g [] (shunt_labels ++ rendered_rail_tree ++ cars))
+    <| ( model.render_cache.bbox_rail_tree
+       , Svg.g []
+          (shunt_labels
+          ++ [Svg.lazy (always <| Svg.g [] model.render_cache.rendered_rail_tree) ()]
+          ++ cars)
+       )
 
 -- vim: ft=elm et ts=2 sw=2