import Html exposing (Html, div, text, textarea, h1, h2, p)
import Html.Attributes exposing (class, classList)
import Html.Events exposing (onInput)
import Browser exposing (element)
import Canvas exposing (Shape)
import Dict exposing (Dict)
import Parser exposing (Parser, Problem(..), DeadEnd, (|.), (|=), variable, succeed, symbol, int, spaces, map, oneOf, lazy, sequence, Trailing(..), keyword, run, backtrackable, end)
import Color
import Canvas exposing (Point, path, lineTo, circle, shapes, stroke, lineWidth, fill, rect)
import Set

{-
======= Syntax Definitions =======
-}
type LogoPenMode = Up | Down
type LogoExpr = Variable String
          | Number Int
          | Sum LogoExpr LogoExpr
type LogoCmd = Pen LogoPenMode
         | Move LogoExpr LogoExpr
         | Define String (List String) LogoProg
         | Call String (List LogoExpr)
type alias LogoProg = List LogoCmd

{-
======= Semantics Definitions ====
-}

type alias Coord = (Int, Int)
type alias Line = (Coord, Coord)
type alias Function = (List String, LogoProg)

type Scope = Child Scope (Dict String Function) (Dict String Int) | End
type alias Board = List Line
type alias State =
    { penMode : LogoPenMode
    , pos : Coord
    , scope : Scope
    , board : Board
    }

type alias Step a = State -> Result String (a, State)

{-
======= Type Definitions =======
-}

type alias Flags =
    { initialText : String
    }

type alias Model =
    { programText : String
    }

type Msg
    = UpdateText String

{-
======= Syntax Code
-}

parseInt : Parser LogoExpr
parseInt = map Number int

parseVarName : Parser String
parseVarName = variable
    { start = Char.isAlphaNum
    , inner = Char.isAlphaNum
    , reserved = Set.fromList [ "move", "pen", "define", "call" ]
    }

parseVar : Parser LogoExpr
parseVar = map Variable parseVarName

parseTerm : Parser LogoExpr
parseTerm = oneOf [ parseInt, parseVar ]

parseSum : Parser LogoExpr
parseSum = succeed Sum
    |= parseTerm
    |. spaces
    |. symbol "+"
    |. spaces
    |= parseExpr

parseExpr : Parser LogoExpr
parseExpr = oneOf [ lazy (\_ -> backtrackable parseSum), parseTerm ]

parseProg : Parser LogoProg
parseProg = sequence
    { start = ""
    , separator = ""
    , end = ""
    , spaces = spaces
    , item = lazy (\_ -> parseCmd)
    , trailing = Mandatory
    }

parseCmd : Parser LogoCmd
parseCmd = oneOf [ parseDefine, parseCall, parseMove, parsePen ]

parseDefine : Parser LogoCmd
parseDefine = succeed Define
    |. keyword "define"
    |. spaces
    |= parseVarName
    |. spaces
    |= sequence
        { start = "("
        , separator = ","
        , end = ")"
        , spaces = spaces
        , item = parseVarName
        , trailing = Forbidden
        }
    |. spaces
    |. symbol "{"
    |. spaces
    |= parseProg
    |. spaces
    |. symbol "}"

parseCall : Parser LogoCmd
parseCall = succeed Call
    |. keyword "call"
    |. spaces
    |= parseVarName
    |. spaces
    |= sequence
        { start = "("
        , separator = ","
        , end = ")"
        , spaces = spaces
        , item = parseExpr
        , trailing = Forbidden
        }
    |. spaces
    |. symbol ";"

parsePenMode : Parser LogoPenMode
parsePenMode = oneOf
    [ succeed Up |. keyword "up"
    , succeed Down |. keyword "down"
    ]

parsePen : Parser LogoCmd
parsePen = succeed Pen
    |. keyword "pen"
    |. spaces
    |= parsePenMode
    |. spaces
    |. symbol ";"

parseMove : Parser LogoCmd
parseMove = succeed Move
    |. keyword "move"
    |. spaces
    |. symbol "("
    |= parseExpr
    |. spaces
    |. symbol ","
    |. spaces
    |= parseExpr
    |. spaces
    |. symbol ")"
    |. spaces
    |. symbol ";"

{-
======= Semantics Code =======
-}

initialScope : Scope
initialScope = Child End Dict.empty Dict.empty

setScopeFunction : String -> Function -> Scope -> Scope
setScopeFunction s f scope = case scope of
    End -> setScopeFunction s f initialScope
    Child p fs vs -> Child p (Dict.insert s f fs) vs

setScopeVariable : String -> Int -> Scope -> Scope
setScopeVariable s v scope = case scope of
    End -> setScopeVariable s v initialScope
    Child p fs vs -> Child p fs (Dict.insert s v vs)

scopeFunction : String -> Scope -> Maybe Function
scopeFunction s scope = case scope of
    End -> Nothing
    Child p fs _ -> case Dict.get s fs of
        Just f -> Just f
        Nothing -> scopeFunction s p

scopeVariable : String -> Scope -> Maybe Int
scopeVariable s scope = case scope of
    End -> Nothing
    Child p _ vs -> case Dict.get s vs of
        Just i -> Just i
        Nothing -> scopeVariable s p

initialState : State
initialState =
    { penMode = Up
    , pos = (0, 0)
    , scope = initialScope
    , board = []
    }

updatePosition : Coord -> State -> State
updatePosition c state =
    let
        newBoard = case state.penMode of
            Up -> state.board
            Down -> (state.pos, c)::state.board
    in
        { state | pos = c, board = newBoard }

registerFunction : String -> Function -> State -> State
registerFunction s f state = { state | scope = setScopeFunction s f state.scope }

registerVariable : String -> Int -> State -> State
registerVariable s v state = { state | scope = setScopeVariable s v state.scope }

setPenMode : LogoPenMode -> State -> State
setPenMode m state = { state | penMode = m}

upScope : State -> State
upScope state = { state | scope = Child state.scope Dict.empty Dict.empty }

downScope : State -> State
downScope state =
    let
        newScope = case state.scope of
            End -> End
            Child p _ _ -> p
    in
        { state | scope = newScope }

unit : a -> Step a
unit a state = Ok (a, state)

err : String -> Step a
err s state = Err s

bind : Step a -> (a -> Step b) -> Step b
bind sa f state = case sa state of
    Ok (a, newState) -> f a newState
    Err e -> Err e

rbind : (a -> Step b) -> Step a -> Step b
rbind f sa = bind sa f

get : Step State
get s = Ok (s, s)

put : State -> Step ()
put s _ = Ok ((), s)

modify : (State -> State) -> Step ()
modify f = get |> rbind (put << f)

lookupFunction : String -> Step Function
lookupFunction s = get |> rbind (\st -> case scopeFunction s st.scope of
    Just f -> unit f
    Nothing -> err ("No function with name " ++ s))

lookupVariable : String -> Step Int
lookupVariable s = get |> rbind (\st -> case scopeVariable s st.scope of
    Just v -> unit v
    Nothing -> err ("No variable with name " ++ s))

evaluateExp : LogoExpr -> Step Int
evaluateExp le = case le of
    Number i -> unit i
    Variable v -> lookupVariable v
    Sum l r -> evaluateExp l |> rbind (\vl -> evaluateExp r |> rbind (\vr -> unit (vl + vr)))

evaluateAllExps : List LogoExpr -> Step (List Int)
evaluateAllExps = List.foldr (\x acc -> acc |> rbind (\vs -> evaluateExp x |> rbind (\v -> unit (v::vs)))) (unit [])

registerAllVariables : List (String, Int) -> Step ()
registerAllVariables = List.foldl (\(s, i) m -> bind m (\_ -> modify <| registerVariable s i)) (unit ())

zipParams : List String -> List Int -> Step (List (String, Int))
zipParams la lb = case (la, lb) of
    (a::lat, b::lbt) -> zipParams lat lbt |> rbind (\ps -> unit <| (a, b)::ps)
    ([], []) -> unit []
    ([], _) -> err "Passing too many parameters to macro call"
    (_, []) -> err "Not enough parameters in macro call" 

evaluateCmd : LogoCmd -> Step ()
evaluateCmd c = case c of
    Move l r -> evaluateExp l |> rbind (\x -> evaluateExp r |> rbind (\y -> modify <| updatePosition (x, y)))
    Define n xs prg -> modify <| registerFunction n (xs, prg)
    Pen mode -> modify <| setPenMode mode
    Call n args -> lookupFunction n
        |> rbind (\(ns, prg) -> evaluateAllExps args
        |> rbind (\vs -> modify upScope
        |> rbind (\_  -> zipParams ns vs
        |> rbind (\ps -> registerAllVariables ps
        |> rbind (\_  -> evaluateAll prg
        |> rbind (\_  -> modify downScope))))))

evaluateAll : LogoProg -> Step ()
evaluateAll prg = List.foldl rbind (unit ()) <| List.map (\c _ -> evaluateCmd c) prg

{-
======= Drawing Stuff =====
-}
transformCoord : Coord -> Point
transformCoord (x, y) = (toFloat x * 25, 500 - toFloat y * 25)

lineShape : Line -> Shape
lineShape (c1, c2) = path (transformCoord c1) [ lineTo (transformCoord c2) ]

pointerShape : Coord -> Shape
pointerShape c = circle (transformCoord c) 5

allShapes : State -> List Shape
allShapes s = pointerShape s.pos :: List.map lineShape s.board

canvas : State -> Html Msg
canvas state = Canvas.toHtml (500, 500) [ classList [ ("centered", True), ("shadow", True) ] ]
    [ shapes [ fill Color.white ] [ rect (0, 0) 500 500 ]
    , shapes [ stroke Color.blue, lineWidth 5] (allShapes state)
    ]

{-
===== Rendering Stuff
-}

humanProblemString : Problem -> String
humanProblemString p = case p of
    Expecting s -> "Expecting " ++ s
    ExpectingInt -> "Expecting decimal integer"
    ExpectingHex -> "Expecting hexadecimal integer"
    ExpectingOctal -> "Expecting octal integer"
    ExpectingBinary -> "Expecting binary integer"
    ExpectingFloat -> "Expecting a floating pointer number"
    ExpectingNumber -> "Expecting a number"
    ExpectingVariable -> "Expected variable name"
    ExpectingSymbol s -> "Expected symbol \"" ++ s ++ "\""
    ExpectingKeyword s -> "Expecting keyword " ++ s
    ExpectingEnd -> "Expecting end of string"
    UnexpectedChar -> "Unexpected character"
    Problem s -> s
    BadRepeat -> "Bad repetition"

humanDeadEndString : DeadEnd -> String
humanDeadEndString { row, col, problem } =
    "A parse error occured on line "
        ++ String.fromInt row
        ++ ": " ++ humanProblemString problem

humanParseError : List DeadEnd -> String
humanParseError = Maybe.withDefault "" << Maybe.map humanDeadEndString << List.head

{-
======= Elm Architecture =======
-}

init : Flags -> (Model, Cmd Msg)
init fs =
    let
        model =
            { programText = fs.initialText
            }
        cmd = Cmd.none
    in
        (model, cmd)

view : Model -> Html Msg
view m = 
    let 
        parseResult = Result.mapError humanParseError (run (parseProg |. end) m.programText)
        evalResult = Result.map (\(_, s) -> s)
            <| Result.andThen (\prg -> evaluateAll prg initialState) parseResult
        toRender = Result.withDefault initialState evalResult
        error = case evalResult of
            Err e -> [ p [ classList [ ("centered", True), ("error", True), ("shadow", True) ] ] [ text e ] ]
            Ok _ -> []
    in
        div []
            [ h1 [] [ text "MiniLogo Functional Evaluator" ]
            , div [ class "logo-container" ]
                [ div [ class "logo-pane" ] <|
                    [ h2 [] [ text "MiniLogo" ]
                    , textarea [ onInput UpdateText, classList [ ("centered", True), ("shadow", True) ] ] [ text m.programText ]
                    ] ++ error
                , div [ class "logo-pane" ] [ h2 [] [ text "Output" ], canvas toRender ]
                ]
            ]

update : Msg -> Model -> (Model, Cmd Msg)
update msg m = case msg of
    UpdateText s -> ({ m | programText = s }, Cmd.none)

subscriptions : Model -> Sub Msg
subscriptions m = Sub.none

main = element
    { init = init
    , view = view
    , update = update
    , subscriptions = subscriptions
    }