rail-compiler-editor-0.2.0.0: src/RailEditor/EditorBackend.hs
{-# LANGUAGE DeriveDataTypeable#-}
module EditorBackend where
import Data.Typeable (Typeable)
import Data.List.Split (split,keepDelimsL,whenElt,splitWhen)
import Data.Data (Data,toConstr)
import Data.Maybe
-- !!!please dont create dependencies to this module without an announcement, because it is still in the creating and refactoring process!!!
-- Represents a charakter of a programm with the charakter (Char), his coordinate inside the function relative to the $ charakter and a Bool (for determine in the parsing process, whether the process already visited the field)
data Field = Field HighlightChar Bool deriving (Show,Eq)
-- Represents a function, with the name (String) and the Code ([[Field]])
data Function = Function String [[Field]] deriving (Show,Eq)
-- Represents a Programm, which is a set of Functions
data Programm = Programm [Function] deriving (Show,Eq)
-- Represents the next move of the 'train'
data Move = Allowed (Int,Int) | Forbidden (Int,Int) deriving (Show,Eq)
-- Represents the direction of the 'train'
data Direction = North | South | West | East | NorthWest | NorthEast | SouthWest | SouthEast deriving (Show,Eq)
-- Define Highlighting Classes for making highlight with an xml-config file possible in a later version (e.g. <MathOp color=#FF0011> ...)
data HighlightChar = Undefined Char | MathOp Char | StringOp Char | Misc Char | Constant Char | FunctionUse Char | SystemOp Char | VariableOp Char | ListOp Char | Conditional Char | Rail Char | Cross Char | If Char | Mixed Char deriving (Show, Eq, Data, Typeable)
--begin: HighlightChar operations
fromHighlightChar :: HighlightChar -> Char
fromHighlightChar (Undefined c) = c
fromHighlightChar (MathOp c) = c
fromHighlightChar (StringOp c) = c
fromHighlightChar (Misc c) = c
fromHighlightChar (Constant c) = c
fromHighlightChar (FunctionUse c) = c
fromHighlightChar (SystemOp c) = c
fromHighlightChar (VariableOp c) = c
fromHighlightChar (ListOp c) = c
fromHighlightChar (Conditional c) = c
fromHighlightChar (Rail c) = c
fromHighlightChar (Cross c) = c
fromHighlightChar (If c) = c
fromHighlightChar (Mixed c) = c
--end: HighlightChar operations
--begin: Field operations
getFieldChar :: Field -> Char
getFieldChar (Field hChar _) = fromHighlightChar hChar
getFieldVisited :: Field -> Bool
getFieldVisited (Field _ visited) = visited
--end: Field operations
--begin: Function operations
getFunctionFields :: Function -> [[Field]]
getFunctionFields (Function _ fields) = fields
getFunctionName :: Function -> String
getFunctionName (Function name _) = name
--end: Function operations
--begin: Programm operations
getProgrammFunctions :: Programm -> [Function]
getProgrammFunctions (Programm functions) = functions
--end: Programm operations
--begin: Move operations
isAllowed :: Move -> Bool
isAllowed (Forbidden _) = False
isAllowed (Allowed _) = True
fromAllowed :: Move -> (Int,Int)
fromAllowed (Allowed coord) = coord
--end: Move operations
--begin: Operations for converting code - Strings to the ADT 'Programm'
codeToProgramm :: [String] -> Programm
codeToProgramm content = Programm $ map getFunctionByContentChunk $ splitContentInChunks content
splitContentInChunks :: [String] -> [[String]]
splitContentInChunks content = filterEmptyElements $ (split . keepDelimsL . whenElt) isStartSymbol content
where isStartSymbol line | null line = False
| otherwise = (\(x:xs) -> x == '$') line
filterEmptyElements :: [[String]] -> [[String]]
filterEmptyElements = map (filter (/="")).filter (/=[])
getFunctionByContentChunk :: [String] -> Function
getFunctionByContentChunk functionCode@(x:xs) = Function functioName $ readFunctionCodeToAdtFunction functionCode 0
where functioName = splitWhen (=='\'') x !! 1
readFunctionCodeToAdtFunction :: [String] -> Int -> [[Field]]
readFunctionCodeToAdtFunction [] _ = []
readFunctionCodeToAdtFunction (e:es) lineCount = readStringToFieldList e (0,lineCount) : readFunctionCodeToAdtFunction es (succ lineCount)
readStringToFieldList :: String -> (Int,Int) -> [Field]
readStringToFieldList [] _ = []
readStringToFieldList (e:es) (x,y) = Field (Undefined e) False : readStringToFieldList es (succ x,y)
--end: Operations for converting code - Strings to the ADT 'Programm'
--begin: Operations for modify and access 'Field' in a structure
getFieldByCoord :: [[Field]] -> (Int,Int) -> Field
getFieldByCoord fields (x,y) = (fields !! y) !! x
isVisited :: (Int,Int) -> Function -> Bool
isVisited (x,y) (Function _ fields) = b
where (Field _ b) = getFieldByCoord fields (x,y)
markAsVisited :: (Int,Int) -> Function -> Function
markAsVisited (x,y) (Function n fields) = Function n $ up ++ ((left ++ [Field e True] ++ tail right) : tail down)
where (up,down) = splitAt y fields
(left,right) = splitAt x (head down)
(Field e _) = head right
setFieldAt :: Move -> Function -> Field -> Function
setFieldAt (Allowed (x,y)) (Function n fields) field = Function n $ up ++ ((left ++ [field] ++ tail right) : tail down)
where (up,down) = splitAt y fields
(left,right) = splitAt x (head down)
--end: Operations for modify and access 'Field' in a structure
--begin: Functions to decide how the train will move
getNextMove :: (Int,Int) -> Direction -> Function -> Bool -> Move
getNextMove (x,y) direction (Function name fields) includeSecondaryBranch = case direction of
North -> getNorthMove (x,y) fields includeSecondaryBranch
South -> getSouthMove (x,y) fields includeSecondaryBranch
West -> getWestMove (x,y) fields includeSecondaryBranch
East -> getEastMove (x,y) fields includeSecondaryBranch
NorthWest -> getNorthWestMove (x,y) fields includeSecondaryBranch
NorthEast -> getNorthEastMove (x,y) fields includeSecondaryBranch
SouthWest -> getSouthWestMove (x,y) fields includeSecondaryBranch
SouthEast -> getSouthEastMove (x,y) fields includeSecondaryBranch
getNorthMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getNorthMove (x,0) _ includeSecondaryBranch= Forbidden (x,0)
getNorthMove (x,1) _ includeSecondaryBranch= Forbidden (x,1)
getNorthMove (x,y) fields includeSecondaryBranch= Allowed (x,pred y)
getSouthMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getSouthMove (x,y) fields includeSecondaryBranch
| length fields <= y' = Forbidden (x,y)
| otherwise = Allowed (x,y')
where y' = succ y
getEastMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getEastMove (x,y) fields includeSecondaryBranch
| length (fields !! y) <= x' = Forbidden (x,y)
| otherwise = Allowed (succ x,y)
where x' = succ x
getWestMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getWestMove (0,y) _ includeSecondaryBranch = Forbidden (0,y)
getWestMove (x,y) _ includeSecondaryBranch = Allowed (pred x,y)
{-
Primary: Secondary: Secondary2:
\ --\ |
\ \
-}
getNorthWestMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getNorthWestMove (x,y) fields includeSecondaryBranch
| primary /= ' ' = Allowed (x',y')
| includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))
| otherwise = Forbidden (x,y)
where x' = pred x
y' = pred y
primary | x <= 0 || y <= 1 || length (fields !! y') <= x' = ' '
| otherwise =getFieldChar $ getFieldByCoord fields (x',y')
secondary = secondaryChar == '-'
secondary2 = secondaryChar2 == '|'
secondaryChar | x == 0 = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y)
secondaryChar2 | y <= 1 || length (fields !! y') <= x = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x,y')
{-
Primary: Secondary: Secondary2:
/ /- |
/ /
-}
getNorthEastMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getNorthEastMove (x,y) fields includeSecondaryBranch
| primary /= ' ' = Allowed (x',y')
| includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))
| otherwise = Forbidden (x,y)
where x' = succ x
y' = pred y
primary | y <= 1 || length (fields !! y') <= x' = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y')
secondary = secondaryChar == '-'
secondary2 = secondaryChar2 == '|'
secondaryChar | length (fields !! y) <= x' = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y)
secondaryChar2 | y <= 1 || length (fields !! y') <= x = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x,y')
{-
Primary: Secondary: Secondary2:
/ -/ /
/ |
-}
getSouthWestMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getSouthWestMove (x,y) fields includeSecondaryBranch
| primary /= ' ' = Allowed (x',y')
| includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))
| otherwise = Forbidden (x,y)
where x' = pred x
y' = succ y
primary | length fields <= y' || x == 0 = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y')
secondary = secondaryChar == '-'
secondary2 = secondaryChar2 == '|'
secondaryChar2 | length fields <= y' || length (fields !! y') <= x = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x,y')
secondaryChar | x == 0 = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y)
{-
Primary: Seondary: Secondary2:
\ \- \
\ |
-}
getSouthEastMove :: (Int,Int) -> [[Field]] -> Bool -> Move
getSouthEastMove (x,y) fields includeSecondaryBranch
| primary /= ' ' = Allowed (x',y')
| includeSecondaryBranch && (secondary `xor` secondary2) = Allowed (getSecondary secondary (x',y) secondary2 (x,y'))
| otherwise = Forbidden (x,y)
where x' = succ x
y' = succ y
primary | length fields <= y' || length (fields !! y') <= x' = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y')
secondary = secondaryChar == '-'
secondary2 = secondaryChar2 == '|'
secondaryChar | length (fields !! y) <= x' = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x',y)
secondaryChar2 | length fields <= y' || (length (fields !! y') <= x) = ' '
| otherwise = getFieldChar $ getFieldByCoord fields (x,y')
getSecondary :: Bool -> (Int,Int) -> Bool -> (Int,Int) -> (Int,Int)
getSecondary secondary1 coord1 secondary2 coord2
| secondary1 = coord1
| otherwise = coord2
getNewDirection :: Char -> Direction -> Direction
getNewDirection newChar oldDir
| isJust newDir = fromJust newDir
| otherwise = oldDir
where dirMap = [((SouthEast,'-'),East),
((SouthWest,'-'),West),
((East,'/'),NorthEast),
((West,'\\'),NorthWest),
((East,'\\'),SouthEast),
((West,'/'),SouthWest),
((SouthEast,'|'),South),
((NorthEast,'|'),North),
((SouthWest,'|'),South),
((NorthWest,'|'),North),
((South,'/'),SouthWest),
((South,'\\'),SouthEast),
((North,'\\'),NorthWest),
((North,'/'),NorthEast)]
newDir = lookup (oldDir,newChar) dirMap
--end: Functions to decide how the train will move
xor :: Bool -> Bool -> Bool
xor a b = a /= b
goStep :: Move -> Function -> Direction -> (Move,Function,Direction)
goStep (Forbidden a) function dir = (Forbidden a,function,dir)
goStep (Allowed (x,y)) function@(Function _ fields) dir = (nextCoord,visitedFunction,newDir)
where visitedFunction = markAsVisited (x,y) function
nextCoord = getNextMove (x,y) dir visitedFunction True
newDir | isAllowed nextCoord = getNewDirection (getFieldChar(getFieldByCoord fields ( fromAllowed nextCoord))) dir
| otherwise = dir
exCode3 = ["$ 'main'"," \\"," \\"," \\----\\"," \\"," |"," #---/"]
exFunction3 = getFunction exCode3
exCode2 = ["$ 'main'"," \\ /----\\"," \\ |"," \\----/"]
exFunction2 = getFunction exCode2
getFunction code = e
where (Programm (e:es)) = codeToProgramm code