port module Mucegai exposing (main, init, update, view)

import Browser
import Html exposing (Html, button, div, span, text)
import Html.Attributes exposing (class)
import Html.Events exposing (onClick)
import Browser.Events exposing (onKeyDown)

import Array exposing (Array)
import Json.Decode as Decode

import Time



--  MAIN

main : Program () Model Msg
main =
  Browser.document
    { init          = init
    , update        = update
    , view          = view
    , subscriptions = subscriptions }



--  MODEL

type State
  = Paused
  | Playing

type Direction
  = Up
  | Down
  | Left
  | Right

type alias Cell =
  { operator    : String
  , lastTrigger : Int
  }

type alias HeadState =
  { y : Int
  , x : Int
  , d : Direction
  , stack : List Int
  }

type alias Model =
  { state   : State
  , tempo   : Int
  , ticks   : Int
  , pointer : (Int, Int)
  , heads   : List HeadState
  , cells   : Array (Array Cell)
  }

init : () -> (Model, Cmd Msg)
init () =
  ( { state = Paused
    , tempo = 480
    , ticks = 0
    , pointer = (0, 0)
    , heads = []
    , cells =
      let defaultCell = { operator = ".", lastTrigger = -100 } in
      Array.repeat 20 (Array.repeat 30 defaultCell)
    }
  , Cmd.none
  )



--  SUBSCRIPTIONS

keyDecoder : Decode.Decoder Msg
keyDecoder =
  let
    allowedKeys =
      [ "v", "^", "<", ">", "!", ".", ":", "o", "x", "h",
        "a", "b", "c", "d", "e", "f", "g", "+", "-",
        "0", "1", "2", "3", "4", "5", "6", "7", "8", "9",
        "]", ")", "~", "/", "@", ";"
      ]
    decodeAction k =
      case k of
        "ArrowLeft" ->
          MovePointer 0 -1
        "ArrowRight" ->
          MovePointer 0 1
        "ArrowUp" ->
          MovePointer -1 0
        "ArrowDown" ->
          MovePointer 1 0
        other ->
          if List.any (\s -> s == other) allowedKeys then
            UpdateCell other
          else
            NoOp
  in
  Decode.field "key" Decode.string
    |> Decode.map decodeAction

subscriptions : Model -> Sub Msg
subscriptions model =
  case model.state of
    Playing ->
      Sub.batch
        [ onKeyDown keyDecoder
        , Time.every (60000 / toFloat model.tempo) Advance
        ]
    Paused ->
      onKeyDown keyDecoder



--  PORTS

port triggerSample : Int -> Cmd msg
port triggerNote   : Int -> Cmd msg



--  UPDATE

type Msg
  = Play
  | Pause
  | SetPointer Int Int
  | MovePointer Int Int
  | UpdateCell String
  | Advance Time.Posix
  | NoOp

updateCell : Array (Array Cell) -> Int -> Int -> Cell -> Array (Array Cell)
updateCell cells y x ch =
  case Array.get y cells of
    Just row ->
      case Array.get x row of
        Just _ ->
          let newRow = Array.set x ch row in
          Array.set y newRow cells
        Nothing -> cells
    Nothing -> cells

touchCell : Array (Array Cell) -> Int -> Int -> Int -> Array (Array Cell)
touchCell cells y x lt =
  case Array.get y cells of
    Just row ->
      case Array.get x row of
        Just cell ->
          let newRow = Array.set x { cell | lastTrigger = lt } row in
          Array.set y newRow cells
        Nothing -> cells
    Nothing -> cells

findHeads : Model -> List HeadState
findHeads model =
  let
    findSourcesInRow (idx, row) =
      Array.indexedMap (\i e -> (idx, i, e)) row
        |> Array.filter (\(_, _, s) -> s.operator == "!")
        |> Array.toList
        |> List.map (\(y, x, _) -> { y = y, x = x, d = Down, stack = [] })
    indexedRows =
      Array.indexedMap (\i e -> (i, e)) model.cells
        |> Array.toList
  in
    List.concatMap findSourcesInRow indexedRows

getCell : Array (Array Cell) -> Int -> Int -> Maybe Cell
getCell cells y x =
  Array.get y cells
    |> Maybe.andThen (Array.get x)

collectCommands : Model -> HeadState -> ((Cmd Msg, List (Int, Int)), HeadState)
collectCommands model start =
  let
    interpretEffect op state =
      case op of
        Just ")" ->
          case pop state.stack of
            Just (hd, _) -> [ triggerSample hd ]
            Nothing -> []
        Just "]" ->
          case pop state.stack of
            Just (hd, _) -> [ triggerNote hd ]
            Nothing -> []
        _ ->
          []

    move state =
      case state.d of
        Up    -> { state | y = state.y - 1 }
        Down  -> { state | y = state.y + 1 }
        Left  -> { state | x = state.x - 1 }
        Right -> { state | x = state.x + 1 }

    pop stack =
      case stack of
        hd :: tl -> Just (hd, tl)
        [] -> Nothing

    drop stack =
      case stack of
        _ :: tl -> tl
        [] -> []

    swap stack =
      let
        newStack =
          pop stack
          |> Maybe.andThen (\(a, tl_a) ->
            pop tl_a
            |> Maybe.andThen (\(b, tl_b) ->
              Just (b :: a :: tl_b)))
      in
        case newStack of
          Just s ->
            s
          Nothing ->
            stack

    interpret op acc t state =
      let
        pushAndMove n =
          let newState = move state in
          collect acc tt { newState | stack = n :: state.stack }

        tt =
          (state.y, state.x) :: t
      in
      case op of
        --  DROP
        Just ";" ->
          let
            newStack = drop state.stack
            newState = { state | stack = newStack }
          in
            collect acc tt (newState |> move)
        
        --  SWAP
        Just "@" ->
          let
            newStack = swap state.stack
            newState = { state | stack = newStack }
          in
            collect acc tt (newState |> move)

        --  COND
        Just "/" ->
          let
            newDir =
              case pop state.stack of
                Just (hd, _) ->
                  if hd == 0 then
                    case state.d of
                      Up    -> Right
                      Right -> Up
                      Down  -> Left
                      Left  -> Down
                  else
                    state.d
                Nothing ->
                  state.d

            newState = { state | d = newDir }
          in
            collect acc tt (newState |> move)

        --  REST
        Just ":" ->
          case pop state.stack of
            Just (hd, tl) ->
              if hd == 0 then
                let newState = move state in
                collect acc tt { newState | stack = tl }
              else
                (acc, tt, { state | stack = (hd - 1) :: tl })
            Nothing ->
              (acc, tt, move state)

        --  MOVEMENT
        Just ">" -> collect acc tt { state | x = state.x + 1, d = Right }
        Just "<" -> collect acc tt { state | x = state.x - 1, d = Left }
        Just "^" -> collect acc tt { state | y = state.y - 1, d = Up }
        Just "v" -> collect acc tt { state | y = state.y + 1, d = Down }

        --  LITERALS
        Just "0" -> pushAndMove 0
        Just "1" -> pushAndMove 1
        Just "2" -> pushAndMove 2
        Just "3" -> pushAndMove 3
        Just "4" -> pushAndMove 4
        Just "5" -> pushAndMove 5
        Just "6" -> pushAndMove 6
        Just "7" -> pushAndMove 7
        Just "8" -> pushAndMove 8
        Just "9" -> pushAndMove 9
        Just "a" -> pushAndMove 10
        Just "b" -> pushAndMove 11
        Just "c" -> pushAndMove 12

        Just "+" ->
          let
            result = 
              pop state.stack
                |> Maybe.andThen (\(a, tl_a) ->
                  pop tl_a
                    |> Maybe.andThen (\(b, tl) ->
                      Just (a + b, tl)))
            newState =
              case result of
                Just (sum, stack) ->
                  { state
                  | stack = sum :: stack
                  }

                Nothing ->
                  state
          in
            collect acc tt (newState |> move)

        Just "-" ->
          let
            result = 
              pop state.stack
                |> Maybe.andThen (\(a, tl_a) ->
                  pop tl_a
                    |> Maybe.andThen (\(b, tl) ->
                      Just (b - a, tl)))
            newState =
              case result of
                Just (dif, stack) ->
                  { state
                  | stack = dif :: stack
                  }

                Nothing ->
                  state
          in
            collect acc tt (newState |> move)

        Just _ ->
          let
            eff = interpretEffect op state
          in
          if List.isEmpty eff then
            collect acc tt (state |> move)
          else
            collect (List.concat [eff, acc]) tt ( state |> move)
        Nothing -> (acc, tt, state)

    collect : List (Cmd Msg) -> List (Int, Int) -> HeadState -> (List (Cmd Msg), List (Int, Int), HeadState)
    collect acc tt state =
      let
        op =
          getCell model.cells state.y state.x
          |> Maybe.map (\c -> c.operator)
      in
        if List.member (state.y, state.x) tt then
          (acc, tt, state)
        else
          interpret op acc tt state

    (effects, touched, end) = collect [] [] start
  in
    ( ( Cmd.batch effects
      , touched
      )
    , end
    )


advance : Model -> (Model, Cmd Msg)
advance model =
  let
    --(triggers, newHeads) = List.unzip (List.map (advanceHead model) model.heads)
    (effects, newHeads) = List.unzip (List.map (collectCommands model) model.heads)
    (triggers, touched) = List.unzip effects
    newCells = List.foldl (\(y, x) a -> touchCell a y x model.ticks) model.cells (List.foldr (++) [] touched)
  in
  ( { model
    | heads = newHeads
    , cells = newCells
    , ticks = model.ticks + 1
    }
  , Cmd.batch triggers
  )

update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
  case msg of
    Play ->
      ( { model
        | heads = findHeads model
        , state = Playing
        , ticks = 0
        }
      , Cmd.none
      )

    Pause ->
      ( { model
        | state = Paused
        }
      , Cmd.none
      )

    SetPointer y x ->
      ( { model
        | pointer = (y, x)
        }
      , Cmd.none
      )

    MovePointer dy dx ->
      ( { model
        | pointer =
          let
            (y, x) = model.pointer
          in
            (y + dy, x + dx)
        }
      , Cmd.none
      )

    UpdateCell ch ->
      ( { model
        | cells =
          let (y, x) = model.pointer in
          updateCell model.cells y x { operator = ch, lastTrigger = -100 }
        }
      , Cmd.none
      )

    Advance _ -> advance model

    NoOp ->
      ( model
      , Cmd.none
      )


-- VIEW

viewCell : Model -> Int -> Int -> Cell -> Html Msg
viewCell model y x cell =
  let
    handler = onClick (SetPointer y x)
    isUnderPointer =
      if model.pointer == (y, x) then
        [ class "selected" ]
      else
        []
    isUnderHead =
      if List.any (\h -> h.y == y && h.x == x) model.heads then
        [ class "head" ]
      else
        []
    isRecent =
      if model.ticks - cell.lastTrigger == 1 then
        [ class "triggered" ]
      else
        []
    isDimmed =
      if cell.operator == "." then
        [ class "dim" ]
      else
        []
    isMovement =
      if cell.operator == ">" || cell.operator == "<" || cell.operator == "^" || cell.operator == "v" then
        [ class "movement" ]
      else
        []
    classes =
      List.concat
        [ isUnderPointer
        , isUnderHead
        , isRecent
        , isDimmed
        , isMovement
        , [class "cell"]
        ]
  in
    div (handler :: classes) [ text cell.operator ]

viewRow : Model -> Int -> Array Cell -> Html Msg
viewRow model y row =
  let cells = Array.indexedMap (viewCell model y) row in
  div [ class "row"] (Array.toList cells)

viewPlayground : Model -> Html Msg
viewPlayground model =
  let rows = Array.indexedMap (viewRow model) model.cells in
  div [ class "playground" ] (Array.toList rows)

viewHeadStates : Model -> Html Msg
viewHeadStates model =
  let
    viewStackElement el =
      span [ class "stack-element" ] [ text (String.fromInt el) ]
    viewHeadState state =
      div [ class "state" ] (List.map viewStackElement state)
  in
    div [] (List.map (\h -> viewHeadState h.stack) model.heads)

view : Model -> Browser.Document Msg
view model =
  let
    title = "mu/ce/gai"
    body = [
      div []
        [ div [ class "row", class "title" ]
            [ span [] [ text "mu" ]
            , span [] [ text "/" ]
            , span [] [ text "ce" ]
            , span [] [ text "/" ]
            , span [] [ text "gai" ]
            ]
        , viewPlayground model
        , div [ class "row" ]
            [ button [ onClick Play ] [ text "play" ]
            , button [ onClick Pause ] [ text "stop" ]
            ]
        , viewHeadStates model
        ]
      ]
  in
    { title = title, body = body }