Commit c4db2efe authored by Reg Huijben's avatar Reg Huijben

Added the management task using svg

parent f401a0fa
definition module designImage
import trackState
from Graphics.Scalable.Image import :: Image, :: Image`
myImage :: State -> Image State
//myImage :: State -> Image [Tile]
implementation module designImage
import iTasks.Extensions.SVG.SVGEditor
import trackState
import Data.List
import StdEnv
myImage :: State -> Image State
myImage 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
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 [] offs imgs NoHost) where
offs = [(px 0.0, px 0.0): fst3 (unzip3 (sortedList (t, i)))]
imgs = [backgroundSquare: snd3 (unzip3 (sortedList (t, i)))]
sortedList (t,i) = sortBy (\(_,_,active) _. not active) (aList (t,i))
henkkk (aoff, aimgs, aact) b = not aact
aList :: (Tile,Int) -> [(ImageOffset,Image State, Bool)]
aList (t,i) = [
( (px half, px 0.0) , (ns t i), t.ns ),
( (zero, px half), (ew t i), t.ew),
( (px 0.0, px 0.0), (ne t i), t.ne),
( (px half, px 0.0), (nw t i), t.nw),
((px 0.0, px half),(sw t i), t.sw ),
((px half, px half), (se t i),t.se)
]
ne tile i = line (px (half)) (px (0.0-half))
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & ne = not tile.ne} s.tiles ) } , local = False}
<@< { stroke = toSVGColor (if tile.ne activecol inactivecol)}
<@< { strokewidth = (px (strw))}
<@< { mask = (rect (px half) (px half) <@< {fill = toSVGColor "white"})}
nw tile i = line (px (full)) (px full)
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & nw = not tile.nw} s.tiles ) } , local = False}
<@< { stroke = toSVGColor (if tile.nw activecol inactivecol)}
<@< { strokewidth = (px (strw))}
<@< { mask = (rect (px (half + (strw))) (px (half + (strw))) <@< {fill = toSVGColor "white"})}
sw tile i = line (px (half)) (px (half))
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & sw = not tile.sw} s.tiles ) } , local = False}
<@< { strokewidth = (px (strw))}
<@< { stroke = toSVGColor (if tile.sw activecol inactivecol)}
swOLD tile i = line (px (full)) (px (full))
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & sw = not tile.sw} s.tiles ) } , local = False}
<@< { stroke = toSVGColor (if tile.sw activecol inactivecol)}
<@< { strokewidth = (px (strw))}
<@< { mask = (rect (px half) (px half) <@< {fill = toSVGColor "white"})}
se tile i = line (px half) (px (0.0 - half))
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & se = not tile.se} s.tiles ) } , local = False}
<@< { stroke = toSVGColor (if tile.se activecol inactivecol)}
<@< { strokewidth = (px (toReal (strw)))}
<@< { mask = (rect (px half) (px half) <@< {fill = toSVGColor "white"})}
ns tile i = line (px 0.0) (px full)
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & ns = not tile.ns} s.tiles ) } , local = False}
<@< { stroke = toSVGColor (if tile.ns activecol inactivecol)}
<@< { strokewidth = (px (strw))}
ew tile i = line (px full) (px 0.0)
<@< { onclick = \span s.{s & tiles = (updateAt i {tile & ew = not tile.ew} s.tiles ) } , local = False}
<@< { stroke = toSVGColor (if tile.ew activecol inactivecol)}
<@< { strokewidth = (px (strw))}
backgroundSquare = square (px full)
<@< { strokewidth = (px (strw /4.0))}
<@< { stroke = toSVGColor "dimgray"}
<@< { fill = toSVGColor "forestgreen"}
font = normalFontDef "Ariel" height
height = 40.0
module lcsm2
import iTasks
import StdDebug
//import StdDebug
import designImage
from iTasks.Extensions.SVG.SVGEditor import fromSVGEditor, :: SVGEditor {..}
from Graphics.Scalable.Types import :: TagSource, :: TagRef, :: ImageTag
derive class iTask State
derive class iTask Tile
:: LCSMWorkflowCollection =
{
......@@ -16,6 +23,13 @@ instance Startable LCSMWorkflowCollection
,onRequest "/" (loginAndManageWork "T" Nothing Nothing False)
]
state :: SimpleSDSLens State
state = sharedStore "sharedState" {tiles = (take (5*9) (repeat tl)) }
tl = {ne = False, nw = False, se = False, sw = False, ew = False, ns = False}
:: LCSMUser = {name :: String, roles :: [String] }
lcsm_users :: [LCSMUser]
......@@ -43,10 +57,25 @@ importUsers = allTasks (map (createUser o mkUserAccount) lcsm_users)
setup :: [Workflow] -> LCSMWorkflowCollection
setup w = { LCSMWorkflowCollection|workflows = w }
designTask = viewInformation [] "Designer Task"
//designTask = viewInformation [] "Designer Task"
controlTask = viewInformation [] "Controller Task"
driverTask = viewInformation [] "Driver Task"
designTask =
updateSharedInformation
[UpdateSharedUsing
id//(\s -> s.tiles)//id
//(\m v. {m & tiles = v})//(\m v-> v.tiles)//id
(\m v.v)
(\s v.Just s)
(fromSVGEditor
{ initView = id//(\s -> s.tiles)//id
, renderImage = \m v ts.myImage m
, updModel = \m v.v//{m&tiles = v}//\m v.v
})
] state
lcsm_Workflows =
[restrictedWorkflow "Track Management" "This task manages how the tracks look like and how they are connected" ["designer"] designTask
,restrictedWorkflow "Signal Control" "This task manages which signals are red and which are green" ["controller"] controlTask
......
definition module trackState
:: Tile =
{ ne :: Bool
, nw :: Bool
, se :: Bool
, sw :: Bool
, ns :: Bool
, ew :: Bool
}
:: State =
{ tiles :: [Tile]
}
implementation module trackState
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