Commit 6acdab06 authored by Job Cuppen's avatar Job Cuppen

added functionality for adding trains

parent e4ad99c2
......@@ -6,6 +6,8 @@ import iTasks
import designImage
import controllerImage
import driverImage
import trainImage
from iTasks.Extensions.SVG.SVGEditor import fromSVGEditor, :: SVGEditor {..}
from Graphics.Scalable.Types import :: TagSource, :: TagRef, :: ImageTag
......@@ -29,10 +31,11 @@ instance Startable LCSMWorkflowCollection
state :: SimpleSDSLens State
state = sharedStore "sharedState" {tiles = tilelist }
state = sharedStore "sharedState" {tiles = defaultTilelist }
tilelist = updateAt (5) {defaultTile & ew = True, twest = True} (updateAt (4+18) {defaultTile & ns = True, tsouth = True} ( updateAt (4+9) {defaultTile & ns = True, sw = True} (updateAt 4 {defaultTile & tsouth = True, ns = True, se = True} defaultTilelist)))
defaultTilelist = (take (5*9) (repeat defaultTile))
defaultTile = { ne = False, nw = False, se = False, sw = False, ew = False, ns = False // no tracks
, north = Blocked, south = Blocked, west = Blocked, east = Blocked // all switches blocked
, tnorth = False, teast = False, tsouth = False, twest = False // no trains
......@@ -83,6 +86,18 @@ controlTask =
, updModel = \m v.v//{m&tiles = v}//\m v.v
})
] state
-||-
updateSharedInformation
[UpdateSharedUsing
id
(\m v.v)
(\s v.Just s)
(fromSVGEditor
{ initView = id//(\s -> s.tiles)//id
, renderImage = \m v ts.myTrainImage m
, updModel = \m v.v//{m&tiles = v}//\m v.v
})
] state
designTask =
updateSharedInformation
......
definition module trainImage
import trackState
from Graphics.Scalable.Image import :: Image, :: Image`
myTrainImage :: State -> Image State
implementation module trainImage
import iTasks.Extensions.SVG.SVGEditor
import trackState
import Data.List
import StdEnv
import StdDebug
myTrainImage :: State -> Image State
myTrainImage state = margin (px 20.0, px 20.0)
(grid (Columns 9) (RowMajor, LeftToRight, TopToBottom) [] [] [] [] (createTiles state) NoHost)
strw = 6.0
full = 100.0
half = full/2.0
quarter = half/2.0
zero = px 0.0
activecol = "goldenrod"
inactivecol = "darkolivegreen"//"whitesmoke" // "lightgray"
myCoolTiles :: State -> [(Tile,Int)]
myCoolTiles s = (zipWith (\t i.(t,i)) s.tiles [0..])
createTiles :: State -> [Image State]
createTiles s = map createTile (myCoolTiles s)
createTile :: (Tile,Int) -> Image State
//createTile (t,i) = overlay [(AtMiddleX,AtMiddleY),(AtMiddleX,AtMiddleY)] offs imgs NoHost where
createTile (t,i) = overlay all offs imgs NoHost where
all = [(AtLeft,AtTop): fst4 (unzip4 (filteredSwitchList (t, i)))]
offs = [(zero, zero): snd4 (unzip4 (filteredSwitchList (t, i)))]
imgs = [createTracksOfTile (t,i): thd4 (unzip4 (filteredSwitchList (t, i)))]
// welp
fst4 :: (a, b, c,d) -> a
fst4 (a,_,_,_) = a
snd4 :: (a, b, c,d) -> b
snd4 (_,b,_,_) = b
thd4 :: (a, b, c,d) -> c
thd4 (_,_,c,_) = c
filteredSwitchList (t,i) = filter (\(_,_,_,active). active) (switchList (t,i))
switchList :: (Tile,Int) -> [(XYAlign,ImageOffset,Image State, Bool)]
switchList (t,i) = [
// ((AtLeft,AtBottom), (px quarter, zero), switchIndicatorLine False, t.tsouth && drawL t.south),
// ((AtRight,AtBottom), (px (0.0-quarter),zero), switchIndicatorLine True, t.tsouth && drawR t.south),
// ((AtMiddleX,AtBottom), (zero, zero), switchIndicatorLine2 False, t.tsouth && drawM t.south),
// ((AtRight,AtTop), (px (0.0-quarter), zero), switchIndicatorLine False, t.tnorth && drawL t.north),
// ((AtLeft,AtTop), (px quarter, zero), switchIndicatorLine True, t.tnorth && drawR t.north),
// ((AtMiddleX,AtTop), (zero, zero), switchIndicatorLine2 False, t.tnorth && drawM t.north),
// ((AtRight,AtBottom), (zero, px (0.0-quarter)), switchIndicatorLine True, t.teast && drawL t.east),
// ((AtRight,AtTop), (zero, px quarter), switchIndicatorLine False, t.teast && drawR t.east),
// ((AtRight,AtMiddleY), (zero, zero), switchIndicatorLine2 True, t.teast && drawM t.east),
// ((AtLeft,AtTop), (zero, px quarter), switchIndicatorLine True, t.twest && drawL t.west),
// ((AtLeft,AtBottom), (zero, px (0.0-quarter)), switchIndicatorLine False, t.twest && drawR t.west),
// ((AtLeft,AtMiddleY), (zero, zero), switchIndicatorLine2 True, t.twest && drawM t.west),
((AtMiddleX,AtTop), (zero, zero), train t i, t.tnorth),
((AtRight,AtMiddleY), (zero, zero), train t i, t.teast),
((AtMiddleX,AtBottom), (zero, zero), train t i, t.tsouth),
((AtLeft,AtMiddleY), (zero, zero), train t i, t.twest),
((AtLeft,AtTop), (zero, zero), foregroundSquare t i, True)
// ((AtLeft, AtTop), (px 0.0, px 0.0), empty (px full) (px full) , True)
//((px 0.0, px (half - strw)), (south t i), drawWest t )
]
drawM dir = case dir of
Middle -> True
_ -> False
drawL dir = case dir of
Left -> True
_ -> False
drawR dir = case dir of
Right -> True
_ -> False
/*
cyanStroke = { stroke = toSVGColor "cyan"}
switchStrokeWidth = { strokewidth = px (strw/2.0)}
*/
/*
switchIndicatorLine2 hor = if hor ln2 ln where
ln = line zero lnWidth
<@< cyanStroke
<@< switchStrokeWidth
ln2 = line lnWidth zero
<@< cyanStroke
<@< switchStrokeWidth
lnWidth = px (sqrt ((quarter^2.0)*2.0))
switchIndicatorLine flp = if flp (flipx ln) ln where
ln = line lnWidth lnWidth
<@< cyanStroke
<@< switchStrokeWidth
lnWidth = px quarter
*/
createTracksOfTile :: (Tile,Int) -> Image State
createTracksOfTile (t,i) = overlay [] offs imgs NoHost where
offs = [(zero, zero): fst3 (unzip3 (filteredTrackList (t, i)))]
imgs = [backgroundSquare: snd3 (unzip3 (filteredTrackList (t, i)))]
filteredTrackList (t,i) = filter (\(_,_,active). active) (trackList (t,i))
trackList :: (Tile,Int) -> [(ImageOffset,Image State, Bool)]
trackList (t,i) = [
( (px half, zero), ns t i, t.ns),
( (zero, px half), ew t i, t.ew),
( (px half, zero), ne t i, t.ne),
( (zero, zero), nw t i, t.nw),
( (zero, px half), sw t i, t.sw),
( (px half, px half), se t i, t.se)
]
ne tile i = line (px half) (px half)
<@< { stroke = toSVGColor (if tile.ne activecol inactivecol)}
<@< { strokewidth = (px strw)}
nw tile i = line (px half) (px (0.0-half))
<@< { stroke = toSVGColor (if tile.nw activecol inactivecol)}
<@< { strokewidth = (px strw)}
sw tile i = line (px half) (px half)
<@< { strokewidth = (px strw)}
<@< { stroke = toSVGColor (if tile.sw activecol inactivecol)}
se tile i = line (px half) (px (0.0 - half))
<@< { stroke = toSVGColor (if tile.se activecol inactivecol)}
<@< { strokewidth = (px (toReal strw))}
ns tile i = line zero (px full)
<@< { stroke = toSVGColor (if tile.ns activecol inactivecol)}
<@< { strokewidth = (px strw)}
ew tile i = line (px full) zero
<@< { stroke = toSVGColor (if tile.ew activecol inactivecol)}
<@< { strokewidth = (px strw)}
train tile i = circle (px (strw * 2.0))
<@< { strokewidth = (px 1.0) }
<@< { fill = toSVGColor "black" }
moveTrain tile
| tile.tsouth == True = moveToWest tile
| tile.tnorth == True = moveToEast tile
| tile.twest == True = removeTrain tile
| tile.teast == True = moveToSouth tile
| otherwise = moveToNorth tile
moveToWest tile = {tile & tnorth = False, tsouth = False, teast = False, twest = True}
moveToNorth tile = {tile & tnorth = True, tsouth = False, teast = False, twest = False}
moveToEast tile = {tile & tnorth = False, tsouth = False, teast = True, twest = False}
moveToSouth tile = {tile & tnorth = False, tsouth = True, teast = False, twest = False}
removeTrain tile = {tile & tnorth = False, tsouth = False, teast = False, twest = False}
/*
south tile i = circle (px (strw * 2.0))
// <@< { onclick = \span s.{s & tiles = (trace "f" updateAt i {tile & south = Middle} s.tiles ) } , local = False}
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & south = nextDirS tile} s.tiles )} , local = False}
<@< { opacity = if (drawSouth tile) 1.0 0.0 }
<@< { strokewidth = if (drawSouth tile) (px 1.0) zero }
<@< { fill = case tile.south of
Blocked -> toSVGColor "red"
_ -> toSVGColor "yellow" }
north tile i = circle (px (strw * 2.0))
// <@< { onclick = \span s.{s & tiles = (trace "f" updateAt i {tile & south = Middle} s.tiles ) } , local = False}
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & north = nextDirN tile} s.tiles )} , local = False}
<@< { opacity = if (drawNorth tile) 1.0 0.0 }
<@< { strokewidth = if (drawNorth tile) (px 1.0) zero }
<@< { fill = case tile.north of
Blocked -> toSVGColor "red"
_ -> toSVGColor "yellow" }
east tile i = circle (px (strw * 2.0))
// <@< { onclick = \span s.{s & tiles = (trace "f" updateAt i {tile & south = Middle} s.tiles ) } , local = False}
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & east = nextDirE tile} s.tiles )} , local = False}
<@< { opacity = if (drawEast tile) (1.0) (0.0) }
<@< { strokewidth = if (drawEast tile) (px 1.0) zero }
<@< { fill = case tile.east of
Blocked -> toSVGColor "red"
_ -> toSVGColor "yellow" }
west tile i = circle (px (strw * 2.0))
// <@< { onclick = \span s.{s & tiles = (trace "f" updateAt i {tile & south = Middle} s.tiles ) } , local = False}
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & twest = False, tnorth = True} s.tiles )} , local = False}
<@< { opacity = if (drawWest tile) (1.0) (0.0) }
<@< { strokewidth = if (drawWest tile) (px 1.0) zero }
<@< { fill = case tile.west of
Blocked -> toSVGColor "red"
_ -> toSVGColor "yellow" }
nextDirS tile = case tile.tsouth of
Blocked = if tile.sw Left (if tile.ns Middle (if tile.se Right Blocked))
Left = if tile.ns Middle (if tile.se Right Blocked)
Middle = if tile.se Right Blocked
Right = Blocked
nextDirN tile = case tile.tnorth of
Blocked = if tile.ne Left (if tile.ns Middle (if tile.nw Right Blocked))
Left = if tile.ns Middle (if tile.nw Right Blocked)
Middle = if tile.nw Right Blocked
Right = Blocked
nextDirW tile = case tile.twest of
Blocked = if tile.nw Left (if tile.ew Middle (if tile.sw Right Blocked))
Left = if tile.ew Middle (if tile.sw Right Blocked)
Middle = if tile.sw Right Blocked
Right = Blocked
nextDirE tile = case tile.teast of
True = False
Left = if tile.ew Middle (if tile.ne Right Blocked)
Middle = if tile.ne Right Blocked
Right = Blocked
//nextDir old = case old of
// Blocked = Left
// Left = Middle
// Middle = Right
// Right = Blocked
drawSouth :: Tile -> Bool
drawSouth t = (length (filter id [t.ns,t.se,t.sw])) >= 2
drawNorth :: Tile -> Bool
drawNorth t = (length (filter id [t.ns,t.ne,t.nw])) >= 2
drawEast :: Tile -> Bool
drawEast t = (length (filter id [t.ne,t.se,t.ew])) >= 2
drawWest :: Tile -> Bool
drawWest t = (length (filter id [t.nw,t.sw,t.ew])) >= 2
//case tile.south of
// Blocked -> toSVGColor "red"
// _ -> toSVGColor "yellow" }
*/
foregroundSquare tile i = square (px full)
<@< { onclick = \span s.{s & tiles = (updateAt i (moveTrain tile) s.tiles )} , local = False}
<@< { opacity = 0.0}
<@< { strokewidth = (px (strw/4.0))}
<@< { stroke = toSVGColor "dimgray"}
<@< { fill = toSVGColor "forestgreen"}
backgroundSquare = square (px full)
<@< { strokewidth = (px (strw/4.0))}
<@< { stroke = toSVGColor "dimgray"}
<@< { fill = toSVGColor "forestgreen"}
font = normalFontDef "Ariel" height
height = 40.0
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment