Commit 1b66842d authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into simplified-interaction-api

parents c25db9d5 17af588b
Pipeline #28171 failed with stage
in 1 minute and 12 seconds
......@@ -25,6 +25,8 @@ import Incidone.Extensions.CrewLists
derive class iTask CommunicationAttempt
derive class iTask ActionPlan
derive gDefault ActionStatus, ItemMeta, ActionProgress
actionStatuses :: SDSLens () [(InstanceNo,InstanceNo,ActionStatus)] ()
actionStatuses = mapRead (map toActionStatus) detachedTaskInstances
......
......@@ -7,6 +7,8 @@ import Text, Text.HTML, Data.List, iTasks.Internal.HtmlUtil
derive class iTask WallContent
derive gDefault ContactMap, ContactMapLayer, ContactMapLayerDefinition, ContactMapMarker, ContactMapRegion, ContactTrack, ContactMapMarkerType, DateTime
wallContent :: SimpleSDSLens WallContent
wallContent = sharedStore "WallContent" (WallOverview defaultValue)
......
......@@ -7,6 +7,8 @@ import Incidone.Util.TaskPatterns
import qualified Data.Map as DM
import Data.Functor
derive gDefault AISContact, DateTime, ContactTrack, Degrees, AIVDM5, AIVDMCNB
syncAISStream :: Task ()
syncAISStream = withShared ([],False,[],False) (\channel -> (sync channel -&&- consume channel) @! ())
where
......
......@@ -21,5 +21,4 @@ derive JSONEncode Temperature, Meters, Feet, Miles, Knots, Degrees, Contac
derive JSONDecode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gText Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEditor Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gDefault Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEq Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
......@@ -29,6 +29,4 @@ gText{|IncidentShort|} _ i = [maybe "" incidentTitle i]
derive JSONEncode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive JSONDecode Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEditor Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gDefault Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
derive gEq Temperature, Meters, Feet, Miles, Knots, Degrees, ContactShort, IncidentShort
......@@ -13,6 +13,8 @@ import Data.Map.GenJSON
import Text, Text.HTML, Data.Either, Data.Functor
import iTasks.UI.Editor.Controls
derive gDefault Contact, ContactMap, ContactStatus, ContactAccessLevel, Credentials, ContactPhoto, ContactTrack, ContactType, Degrees, Document, ContactMapLayer, DateTime, ContactMapLayerDefinition, ContactMapMarker, ContactMapRegion, ContactMapMarkerType
CONVERT_BIN :== "/opt/local/bin/convert"
//CONVERT_BIN :== "/usr/bin/convert"
......
......@@ -4,6 +4,9 @@ import Incidone.OP.Concepts
import Text, Text.HTML
import iTasks.Extensions.DateTime
derive gDefault ContactGeo, CommunicationMean, NewCommunicationMean, ContactStatus, ContactAccessLevel, Credentials, ContactPhoto, ContactTrack, ContactType
derive gDefault DateTime, Contact, Degrees, CommunicationMeanType, Document
class contactTitle a :: a -> String
instance contactTitle Contact
where
......
......@@ -5,6 +5,8 @@ import Incidone.OP.IncidentManagementTasks
import Incidone.OP.ContactManagementTasks
import Incidone.OP.CommunicationManagementTasks
derive gDefault NewContact, IncidentShort, ContactType
generateTestIncident :: Bool -> Task IncidentNo
generateTestIncident closed
= randomChoice [YachtEngineProblems,YachtAground,Medevac]
......
......@@ -9,6 +9,7 @@ import Incidone.Util.SQLSDS
import Data.Functor, Data.Either, Data.Tuple, Data.Func
derive class iTask ContactFilter
derive gDefault PhoneCall, RadioCall, EmailMessage, P2000Message, WeatherData, PersonDetails, VesselDetails, SurferDetails, DiverDetails, AirplaneDetails, HelicopterDetails, CommunicationMean, WeatherType, Gender, VesselType, CommunicationMeanType, Feet, Knots, Meters, Temperature, Degrees, Miles
dbReadSDS :: String -> SDSSequence QueryDef [r] () | mbFromSQL r & TC r
dbReadSDS notifyId = databaseDef >++> sqlReadSDS notifyId
......
......@@ -22,6 +22,7 @@ import Text.HTML
| IncorrectDatabaseTables
derive class iTask DatabaseProblem
derive gDefault ContactMap, ContactMapLayer, ContactMapLayerDefinition, ContactMapMarker, ContactMapRegion, ContactTrack, ContactMapMarkerType, DateTime
configureIncidone :: [Workspace -> Task ()]
configureIncidone = map const [configureDatabase <<@ (Title "Database")
......
......@@ -23,9 +23,7 @@
<!-- load iTasks viewport -->
<script type="text/javascript">
window.onload = function() {
ABC.loading_promise.finally(function(){
itasks.viewport({syncTitle: true}, document.body);
});
};
</script>
</head>
......
......@@ -149,8 +149,8 @@ editDeviceToDevice dev
:: EditDeviceType =
{ kind :: !DeviceKind
, requires :: ![(!CableType, !Capacity)]
, produces :: ![(!CableType, !Capacity)]
, requires :: ![(CableType, Capacity)]
, produces :: ![(CableType, Capacity)]
}
:: EditDevice =
......
......@@ -66,7 +66,7 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode
:: Network =
{ devices :: !Map Coord3D [DeviceId] // [Coord3D |-> DeviceIds]
, cables :: !IntMap Cable // [CableId |-> Cable]
, cableMapping :: !IntMap [(!Operational, !Coord3D)] // [CableId |-> Coord3Ds]
, cableMapping :: !IntMap [(Operational, Coord3D)] // [CableId |-> Coord3Ds]
}
:: Device =
{ description :: !String
......@@ -95,8 +95,8 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode
:: PPDeviceType =
{ kind :: !DeviceKind
, requires :: ![(!CableType, !Capacity)]
, produces :: ![(!CableType, !Capacity)]
, requires :: ![(CableType, Capacity)]
, produces :: ![(CableType, Capacity)]
}
:: CommandAim =
......@@ -169,8 +169,8 @@ cablesInSectionShare :: SDSLens Coord3D [Cable] [Cable]
cablesForSection :: !Coord3D !Network -> [Cable]
allActiveAlarms :: SDSLens () [(!Coord3D, !SectionStatus)] ()
allAvailableActors :: SDSLens () [(!Coord3D, !MyActor)] ()
allActiveAlarms :: SDSLens () [(Coord3D, SectionStatus)] ()
allAvailableActors :: SDSLens () [(Coord3D, MyActor)] ()
// setting and resetting of the detection systems:
......@@ -203,7 +203,7 @@ allImperiledCommandAims :: !(IntMap Device) !CapabilityToDeviceKindMap ![Command
deviceIsDisabledInSection :: !Coord3D !Device !(IntMap Device) !Network -> Bool
isOperational :: !CableId !(IntMap [(!Operational, !Coord3D)]) -> Bool
isOperational :: !CableId !(IntMap [(Operational, Coord3D)]) -> Bool
devicesForCable :: !Cable !(IntMap Device) !Network -> [Device]
......
......@@ -224,7 +224,7 @@ toPPDeviceType { DeviceType | kind, requires, produces } = { PPDeviceType
, produces = 'DM'.toList produces
}
isOperational :: !CableId !(IntMap [(!Operational, !Coord3D)]) -> Bool
isOperational :: !CableId !(IntMap [(Operational, Coord3D)]) -> Bool
isOperational cableId cableMapping = and [b \\ (b, _) <- fromMaybe [] ('DIS'.get cableId cableMapping)]
smokeDetector :: DeviceType
......@@ -383,22 +383,22 @@ patchCable roomNo cableId network = { network & cableMapping = 'DIS'.alter (fmap
inventoryInSectionShare :: FocusedSectionInventoryShare ObjectType
inventoryInSectionShare = mapLens "inventoryInSectionShare" myInventoryMap (Just 'DIS'.newMap)
allAvailableActors :: SDSLens () [(!Coord3D, !MyActor)] ()
allAvailableActors :: SDSLens () [(Coord3D, MyActor)] ()
allAvailableActors
= /*toReadOnly */ (sdsProject (SDSLensRead readActors) (SDSBlindWrite \_. Ok Nothing) Nothing (sectionUsersShare |*| myUserActorMap))
where
readActors :: !(SectionUsersMap, UserActorMap ObjectType ActorStatus) -> MaybeError TaskException [(!Coord3D, !MyActor)]
readActors :: !(SectionUsersMap, UserActorMap ObjectType ActorStatus) -> MaybeError TaskException [(Coord3D, MyActor)]
readActors (sectionUsersMap, userActorMap)
= Ok [(c3d, a) \\ us <- 'DM'.elems sectionUsersMap
, u <- us
, Just (c3d, a) <- [findUser u sectionUsersMap userActorMap]
| a.actorStatus.occupied === Available]
allActiveAlarms :: SDSLens () [(!Coord3D, !SectionStatus)] ()
allActiveAlarms :: SDSLens () [(Coord3D, SectionStatus)] ()
allActiveAlarms
= /*toReadOnly */ (sdsProject (SDSLensRead readAlarms) (SDSBlindWrite \_. Ok Nothing) Nothing myStatusMap)
where
readAlarms :: !MySectionStatusMap -> MaybeError TaskException [(!Coord3D, !SectionStatus)]
readAlarms :: !MySectionStatusMap -> MaybeError TaskException [(Coord3D, SectionStatus)]
readAlarms statusMap = Ok [ (number, status) \\ (number, status) <- 'DM'.toList statusMap
| isHigh status]
......
......@@ -29,7 +29,7 @@ import Data.GenLexOrd
:: MapID :== String // identification of one map
:: Border = Open | Door | Wall
:: Size2D :== (!Real, !Real) // width and height
:: Shape2D :== [(!Real, !Real)] // outline in terms of Map2D.size coordinates (origin at left-top, max at right-bottom)
:: Shape2D :== [(Real, Real)] // outline in terms of Map2D.size coordinates (origin at left-top, max at right-bottom)
:: Maps2DIndex :== Int // index in Maps2D (0..length Maps2D-1)
:: Coord2D = { col :: !Int // x-coordinate (0.., identifies column)
, row :: !Int // y-coordinate (0.., identifies row)
......@@ -37,7 +37,7 @@ import Data.GenLexOrd
:: Coord3D :== (!Maps2DIndex, !Coord2D) // (index in Maps2D, {col,row} in map)
:: Dir = N | E | W | S // north, east, west, south
:: Graph :== Map Coord3D [(!Maybe Dir, !Coord3D)]
:: Graph :== Map Coord3D [(Maybe Dir, Coord3D)]
/********************************************************************************************************************
*
......@@ -145,7 +145,7 @@ moveAround :: !(DrawMapForActor r o a) !User
// finds all actors currently walking on the map, find all objects in the map
findAllObjects :: !(SectionInventoryMap o) -> [(!Coord3D, !Object o)] | iTask o
findAllObjects :: !(SectionInventoryMap o) -> [(Coord3D, Object o)] | iTask o
findUser :: !User !SectionUsersMap !(UserActorMap o a) -> Maybe (!Coord3D, !Actor o a) | iTask o & iTask a
// update the status of an actor, unique username is used as identification
......
......@@ -132,7 +132,7 @@ colToGraph floorIdx rowIdx (graph, colIdx) section
#! graph = 'DM'.put (floorIdx, currCoord2D) (getCoord3Ds section floorIdx currCoord2D section.borders) graph
= (graph, colIdx + 1)
getCoord3Ds :: !Section !Int !Coord2D !Borders -> [(!Maybe Dir, !Coord3D)]
getCoord3Ds :: !Section !Int !Coord2D !Borders -> [(Maybe Dir, Coord3D)]
getCoord3Ds section floorIdx currCoord2D borders
#! acc = []
#! acc = addOnOpening floorIdx borders.n N currCoord2D acc
......@@ -142,7 +142,7 @@ getCoord3Ds section floorIdx currCoord2D borders
#! acc = acc ++ map (\h -> (Nothing, h)) section.hops
= acc
where
addOnOpening :: !Int !Border !Dir !Coord2D ![(!Maybe Dir, !Coord3D)] -> [(!Maybe Dir, !Coord3D)]
addOnOpening :: !Int !Border !Dir !Coord2D ![(Maybe Dir, Coord3D)] -> [(Maybe Dir, Coord3D)]
addOnOpening _ Wall _ _ acc = acc
addOnOpening floorIdx b dir coord2D acc = [(Just dir, (floorIdx, twin dir coord2D)) : acc]
......@@ -684,7 +684,7 @@ doorIsLocked roomNo exit lockMap
// utility functions to find things located in the map
findAllObjects :: !(SectionInventoryMap o) -> [(!Coord3D, !Object o)] | iTask o
findAllObjects :: !(SectionInventoryMap o) -> [(Coord3D, Object o)] | iTask o
findAllObjects objectMap = [ (roomNo, object)
\\ (roomNo, objects) <- 'DM'.toList objectMap
, object <- 'DIS'.elems objects
......
......@@ -9,6 +9,8 @@ import System.Directory, System.FilePath
import Cadastre.SDS, ChamberOfCommerce.SDS, Compensation.SDS, CivilAffairs.SDS
import StdArray, StdFile
derive gDefault Date
batchProcessing :: Task ()
batchProcessing
= pay
......
......@@ -23,7 +23,7 @@ filterDirs _ = True
seq [] = tuple (Ok [])
seq [e:es] = e >>= \a->seq es >>= \as->tuple (Ok [a:as])
recurse :: FilePath -> .(*World -> *(MaybeError OSError [FilePath], !*World))
recurse :: FilePath -> .(*World -> *(MaybeError OSError [FilePath], *World))
recurse root
| endsWith ".dcl" root = tuple (Ok [root])
= getFileInfo root >>= \fi->if fi.directory
......
......@@ -6,14 +6,15 @@ import iTasks.UI.Definition
import StdFunctions, Data.List, Text.HTML
playWithMaps :: Task ()
playWithMaps = withShared ({defaultValue & icons = shipIcons, tilesUrls = ["/tiles/{z}/{x}/{y}.png"]},defaultValue) (\m ->
playWithMaps = withShared ({defaultValue & icons = shipIcons},defaultValue) (\m ->
((allTasks [managePerspective m, manageState m, manageMapObjects m]) <<@ ScrollContent)
-&&-
manipulateMap m
) <<@ ArrangeWithSideBar 0 LeftSide True @! ()
derive gDefault LeafletSimpleState, LeafletObjectID
manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) const (customLeafletEditor eventHandlers)] m
manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) const (customLeafletEditor eventHandlers defaultValue)] m
<<@ ApplyLayout (layoutSubUIs (SelectByPath [1]) (setUIAttributes (sizeAttr FlexSize FlexSize))) @! ()
where
eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent}
......
......@@ -28,6 +28,9 @@ redColor = toSVGColor "red"
freeTileColor = toSVGColor "lightgrey"
transparentColor = toSVGColor "none"
font = normalFontDef "Arial" 14.0
tileSize = px 50.0
toImage :: RenderMode Bool TraxSt *TagSource -> Image TraxSt
toImage ViewMode _ st _
= board False tileSize st
......@@ -61,17 +64,22 @@ where
voidImage :: Span -> Image a
voidImage d = empty d d
illegalImage :: Span -> Image a
illegalImage d = tileShape d <@< {fill = transparentColor}
unselectedImage :: Span -> Image a
unselectedImage d = tileShape d <@< {fill = freeTileColor}
freeImage :: Span Coordinate TraxSt -> Image TraxSt
freeImage d coord {trax,choice}
| maybe True (\c -> coord <> c) choice
= unselected
| isEmpty candidates = illegalImage d
| maybe True ((<>) coord) choice = unselectedImage d <@< {onclick = setcell coord, local = False}
| otherwise = above (repeat AtMiddleX) [] (Just d) []
[tileImage (d /. nr_of_candidates) tile <@< {onclick = settile coord tile, local = False} \\ tile <- candidates]
(Host unselected)
[tileImage (d /. no_of_candidates) tile <@< {onclick = settile coord tile, local = False} \\ tile <- candidates]
(Host (unselectedImage d))
where
candidates = possible_tiles (linecolors trax coord)
nr_of_candidates = length candidates
unselected = tileShape d <@< {fill = freeTileColor} <@< {onclick = setcell coord, local = False}
candidates = [tile \\ tile <- possible_tiles trax coord | isJust (mandatory_moves (add_tile coord tile trax) coord)]
no_of_candidates = length candidates
tileImage :: Span TraxTile -> Image a
tileImage d tile = fromJust (lookup tile [ (horizontal,rotate (deg 0.0) horizontal_tile)
......@@ -93,6 +101,3 @@ where
tileShape :: Span -> Image a
tileShape d = square d <@< {xradius = d /. 10} <@< {yradius = d /. 10}
font = normalFontDef "Arial" 14.0
tileSize = px 50.0
......@@ -18,7 +18,6 @@ derive gEditor TraxTile
derive gText TraxTile
derive JSONEncode TraxTile
derive JSONDecode TraxTile
derive gDefault TraxTile
derive gEq TraxTile
derive gFDomain TraxTile
instance fromTuple TileEdge TileEdge TraxTile
......@@ -74,13 +73,11 @@ col :: !Coordinate -> Int
*/
row :: !Coordinate -> Int
:: Trax
derive gEditor Trax
derive gText Trax
derive JSONEncode Trax
derive JSONDecode Trax
derive gDefault Trax
derive gEq Trax
instance == Trax
instance zero Trax
......@@ -140,10 +137,10 @@ free_coordinates :: !Trax -> [Coordinate]
*/
linecolors :: !Trax !Coordinate -> LineColors
/** possible_tiles @colors = @trax:
returns those @trax that match with @colors.
/** possible_tiles @trax @coordinate = @tiles:
returns those @tiles that constitute a legal move in @trax at @coordinate.
*/
possible_tiles :: !LineColors -> [TraxTile]
possible_tiles :: !Trax !Coordinate -> [TraxTile]
:: Line
......@@ -171,13 +168,6 @@ loops :: !Trax -> [(LineColor,Line)]
*/
winning_lines :: !Trax -> [(LineColor,Line)]
/** mandatory_moves @trax @coordinate = @trax`:
assumes that the tile at @coordinate in @trax is the most recently placed tile.
It performs the mandatory moves that require filling empty places next to this
tile, and all subsequent other empty places, thus resulting in @trax`.
*/
mandatory_moves :: !Trax !Coordinate -> Trax
:: TraxSt
= { trax :: !Trax // the current set of placed tiles
, names :: ![User] // the current two players
......@@ -185,6 +175,16 @@ mandatory_moves :: !Trax !Coordinate -> Trax
, choice :: !Maybe Coordinate
}
/** mandatory_moves @trax @coordinate = Just @trax`:
assumes that the tile at @coordinate in @trax is the most recently placed tile.
It performs the mandatory moves that require filling empty places next to this
tile, and all subsequent other empty places, resulting in @trax`.
mandatory_moves @trax @coordinate = Nothing:
at least one mandatory move occurred that resulted in an illegal configuration:
an empty tile with three or four of the same line colors.
*/
mandatory_moves :: !Trax !Coordinate -> Maybe Trax
/** game_over @st:
returns True only if the given configuration in @st.trax contains one or more
lines that connect opposite board edges, or one or more closed loops.
......
......@@ -20,7 +20,6 @@ derive gEditor TraxTile
derive gText TraxTile
derive JSONEncode TraxTile
derive JSONDecode TraxTile
derive gDefault TraxTile
gFDomain{|TraxTile|} = map fromTuple [(West,East),(North,South),(North,West),(North,East),(South,East),(South,West)]
instance fromTuple TileEdge TileEdge TraxTile where fromTuple (e1,e2) = {end1 = e1, end2 = e2}
instance toTuple TileEdge TileEdge TraxTile where toTuple tile = (tile.end1, tile.end2)
......@@ -82,7 +81,7 @@ instance ~ LineColor where ~ RedLine = WhiteLine
derive gLexOrd Coordinate
instance == Coordinate where == c1 c2 = c1 === c2
instance < Coordinate where < c1 c2 = (c1 =?= c2) === LT
instance zero Coordinate where zero = {col=zero, row=zero}//(zero,zero)
instance zero Coordinate where zero = {col=zero, row=zero}
derive gPrint Coordinate
instance toString Coordinate where toString c = printToString c
......@@ -91,27 +90,21 @@ instance toTuple Int Int Coordinate where toTuple {col,row} = (col,row)
col :: !Coordinate -> Int
col coordinate = coordinate.col
//col (col,_) = col
row :: !Coordinate -> Int
row coordinate = coordinate.row
//row (_,row) = row
north :: !Coordinate -> Coordinate
north coordinate = {coordinate & row = coordinate.row-1}
//north (col,row) = (col, row-1)
south :: !Coordinate -> Coordinate
south coordinate = {coordinate & row = coordinate.row+1}
//south (col,row) = (col, row+1)
west :: !Coordinate -> Coordinate
west coordinate = {coordinate & col = coordinate.col-1}
//west (col,row) = (col-1, row)
east :: !Coordinate -> Coordinate
east coordinate = {coordinate & col = coordinate.col+1}
//east (col,row) = (col+1, row)
go :: !TileEdge -> Coordinate -> Coordinate
go North = north
......@@ -120,14 +113,13 @@ go South = south
go West = west
:: Trax // actually, Trax ought to be opaque
:: Trax
= { tiles :: ![(Coordinate,TraxTile)] // tiles that are placed on a certain location
}
derive gEditor Trax
derive gText Trax
derive JSONEncode Trax
derive JSONDecode Trax
derive gDefault Trax
instance == Trax where == t1 t2 = sortBy fst_smaller t1.tiles == sortBy fst_smaller t2.tiles
gEq{|Trax|} t1 t2 = t1 == t2
instance zero Trax where zero = { tiles = [] }
......@@ -244,9 +236,12 @@ color_at_tile :: !TileEdge !TraxTile -> LineColor
color_at_tile edge tile
= fromJust (lookup1 edge (tilecolors tile))
possible_tiles :: !LineColors -> [TraxTile]
possible_tiles colors
= [tile \\ tile <- gFDomain{|*|} | linecolors_match colors (tilecolors tile)]
possible_tiles :: !Trax !Coordinate -> [TraxTile]
possible_tiles trax free
= matching_tiles
where
tile_pattern = linecolors trax free
matching_tiles = [tile \\ tile <- gFDomain{|*|} | linecolors_match tile_pattern (tilecolors tile)]
/** track @trax @color @edge @coordinate = @line:
computes the entire reachable @line, starting at @coordinate in @trax, and starting
......@@ -280,7 +275,6 @@ where
| otherwise = loops
where
line = track trax color (start_edge tile color) coordinate
// loops = color_loops (removeMembersBy (\(c,t) c` -> c == c`) tiles (cut_loop line)) color
loops = color_loops (deleteFirstsBy (\c` (c,t) -> c == c`) tiles (cut_loop line)) color
/** start_edge @tile @color = @edge:
......@@ -334,27 +328,56 @@ where
, (South,(maxy,miny,row))
]
/** mandatory_tiles @trax @coordinate = @candidates:
@candidates are those immediate, free, neighbours of the tile at @coordinate in @trax
at which two of the same line colors end.
:: MoveStatus // a move status is either:
= ForcedMove // a forced move (two identical edge colors)
| IllegalMove // an illegal move (more than two identical edge colors)
| UnforcedMove // an unforced move (less than two identical edge colors, for both line colors)
derive gEq MoveStatus
instance == MoveStatus where == s1 s2 = s1 === s2
/** tiles_status @trax @coordinate = @tiles:
@tiles are the immediate, free, neighbours of the tile at @coordinate in @trax
together with information about their MoveStatus.
*/
mandatory_tiles :: !Trax !Coordinate -> [Coordinate]
mandatory_tiles trax coordinate
tiles_status :: !Trax !Coordinate -> [(MoveStatus,Coordinate)]
tiles_status trax coordinate
= case tile_at trax coordinate of
Nothing = []
_ = [free \\ free <- free_neighbours trax coordinate
| hasDup (filter isJust (map snd (linecolors trax free)))
]
_ = [(move_status trax free,free) \\ free <- free_neighbours trax coordinate]
where
move_status :: !Trax !Coordinate -> MoveStatus
move_status trax free
| no_of_reds == 2 || no_of_whites == 2 = ForcedMove
| no_of_reds > 2 || no_of_whites > 2 = IllegalMove
| otherwise = UnforcedMove
where
edge_colors = [c \\ (_,Just c) <- linecolors trax free]
no_of_reds = length (filter ((==) RedLine) edge_colors)
no_of_whites = length (filter ((==) WhiteLine) edge_colors)
mandatory_moves :: !Trax !Coordinate -> Trax
mandatory_moves :: !Trax !Coordinate -> Maybe Trax
mandatory_moves trax coordinate
| isNothing (tile_at trax coordinate)
= abort ("Trax.UoD.mandatory_moves: a tile is expected at coordinate " <+ coordinate <+ "\n")
| otherwise
= qfoldl mandatory_tiles move trax (mandatory_tiles trax coordinate)
= qfoldl mandatory_tiles` move (Just trax) (tiles_status trax coordinate)
where
move :: !Trax !Coordinate -> Trax
move trax filler = add_tile filler (hd (possible_tiles (linecolors trax filler))) trax
move :: !(Maybe Trax) !(!MoveStatus,!Coordinate) -> Maybe Trax
move (Just trax) (ForcedMove,filler)
| isEmpty matches = Nothing
| otherwise = Just (add_tile filler (hd matches) trax)
where
matches = possible_tiles trax filler
move (Just trax) (UnforcedMove,_)
= Just trax
move _ _ = Nothing
mandatory_tiles` :: !(Maybe Trax) !(!MoveStatus,!Coordinate) -> [(MoveStatus,Coordinate)]
mandatory_tiles` (Just trax) (ForcedMove,coordinate) = tiles_status trax coordinate
mandatory_tiles` _ _ = []
derive gPrint Trax, TraxTile, TileEdge
instance toString Trax where toString trax = printToString trax
game_over :: !TraxSt -> Bool
game_over st=:{trax}
......@@ -372,4 +395,9 @@ setcell coord st
settile :: !Coordinate !TraxTile !TraxSt -> TraxSt
settile coord tile st=:{trax,turn}
= {st & trax = mandatory_moves (add_tile coord tile trax) coord, choice = Nothing, turn = not turn}
| isNothing trax`
= abort ("Trax.UoD.settile: adding this tile is an illegal move.\n")
| otherwise
= {st & trax = fromJust trax`, choice = Nothing, turn = not turn}
where
trax` = mandatory_moves (add_tile coord tile trax) coord
module WasmTest
import StdEnv
import iTasks
import iTasks.UI.JavaScript
// This is a simple test program to try out things with the WebAssembly ABC interpreter.
Start w = doTasks task w