import Html exposing (Html, div, text, textarea)
import Html.Attributes exposing (class)
import Html.Events exposing (onInput)
import Browser exposing (element)
import Canvas exposing (Shape)
import Dict exposing (Dict)
import Parser exposing (Parser, (|.), (|=), variable, succeed, symbol, int, spaces, map, oneOf, lazy, sequence, Trailing(..), keyword, run, backtrackable)
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
    }

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

parseSum : Parser LogoExpr
parseSum = succeed Sum
    |= oneOf [ backtrackable parseVar, backtrackable parseInt ]
    |. spaces
    |. symbol "+"
    |. spaces
    |= parseExpr

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

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
        }

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

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

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

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

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

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

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

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

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

registerFunction : String -> Function -> Step ()
registerFunction s f state = Ok ((), { state | scope = setScopeFunction s f state.scope })

registerVariable : String -> Int -> Step ()
registerVariable s v state = Ok ((), { state | scope = setScopeVariable s v state.scope })

setPenMode : LogoPenMode -> Step ()
setPenMode m state = Ok ((), { state | penMode = m})

upScope : Step ()
upScope state = Ok ((), { state | scope = Child state.scope Dict.empty Dict.empty })

downScope : Step ()
downScope state =
    let
        newScope = case state.scope of
            End -> End
            Child p _ _ -> p
    in
        Ok ((), { state | scope = newScope })

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

lookupFunction : String -> Step Function
lookupFunction s state = case scopeFunction s state.scope of
    Just f -> Ok (f, state)
    Nothing -> Err ("No function with name " ++ s)

lookupVariable : String -> Step Int
lookupVariable s state = case scopeVariable s state.scope of
    Just i -> Ok (i, state)
    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 (\_ -> registerVariable s i)) (unit ())

zip : List a -> List b -> List (a, b)
zip la lb = case (la, lb) of
    (a::lat, b::lbt) -> (a, b)::zip lat lbt
    _ -> []

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

evaluateAll : LogoProg -> Board -> Step Board
evaluateAll prg board = List.foldl rbind (unit board) <| List.map evaluateCmd 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 : (Board, State) -> List Shape
allShapes (b, s) = pointerShape s.pos :: List.map lineShape b

canvas : (Board, State) -> Html Msg
canvas dat = Canvas.toHtml (500, 500) []
    [ shapes [ fill Color.white ] [ rect (0, 0) 500 500 ]
    , shapes [ stroke Color.blue, lineWidth 5] (allShapes dat)
    ]

{-
======= 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 
        dat = Result.withDefault ([], initialState)
            <| Result.withDefault (Err "Couldn't parse program")
            <| Result.map (\prg -> evaluateAll prg [] initialState) (run parseProg m.programText)
    in
        div [ class "logo-container" ]
            [ div [ class "logo-pane" ] [ textarea [ onInput UpdateText ] [ text m.programText ] ]
            , div [ class "logo-pane" ] [ canvas dat ]
            ]

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
    }