radargame.elm

import Debug (log)
import Keyboard
import Array
import Maybe
import Window

{--
 rader game
 WORK IN PROGRESS
 --}

gameFps = 10

type Pos = { x : Float , y : Float }

data GameState = Ready | Init | PlayerTurn | EnemyTurn | Result

data ShipType = BattleShip | Destroyer | Submarine

data FieldRectType = None | Attack | Selected | BattleShip | Destroyer | Submarine

type GameCondition = {
                       state : GameState
                     , fieldWidth : Float
                     , fieldHeight : Float
                     , cellWidth : Float
                     , cellHeight : Float
                     , enemyFieldRectTypes : Array.Array FieldRectType
                     , playerFieldRectTypes : Array.Array FieldRectType
                     , message : String
                     , battleShipSize : Float
                     , destroyerSize : Float
                     , submarineSize : Float
                     }

-- デフォルトのゲーム設定
defaultGameCondition : GameCondition
defaultGameCondition = {
                         state = Ready
                       , fieldWidth = 10
                       , fieldHeight = 10
                       , cellWidth = 25
                       , cellHeight = 25
                       , enemyFieldRectTypes = Array.empty
                       , playerFieldRectTypes = Array.empty
                       , message = "Press [space] to start game."
                       , battleShipSize = 7
                       , destroyerSize = 4
                       , submarineSize = 3
                       }

-- 戦闘領域の幅
fieldWidth = 10

-- 戦闘領域の高さ
fieldHeight = 10

{-| ----------- -}
{-| ユーザー入力 -}
{-| ----------- -}

-- カーソル位置
cursor : {x : Int, y : Int} -> (Int, Int) -> (Int, Int)
cursor {x, y} (diffX, diffY) =
    let assumedX = x + diffX
        assumedY = y + diffY
        newX = if | assumedX < 0 -> 0
                  | assumedX > 9 -> 9
                  | otherwise -> assumedX
        newY = if | assumedY < 0 -> 0
                  | assumedY > 9 -> 9
                  | otherwise -> assumedY
    in (log "x" newX, log "y" newY)

-- カーソル位置のシグナル
cursorSignal : Signal (Int, Int)
cursorSignal = foldp cursor (0, 0) Keyboard.arrows

-- スペースキーのシグナル
spaceKeySignal : Signal Bool
spaceKeySignal = Keyboard.space

-- サンプリングタイム
delta : Signal Float
delta = inSeconds <~ (fps gameFps)

-- ユーザー入力を一つのレコードにまとめる
type Input = {xy : (Int, Int), spaceKey : Bool}
input : Signal Input
input = sampleOn delta (Input <~ cursorSignal ~ spaceKeySignal)

{-| ゲーム状態に関するシグナル -}

-- ゲーム状態 TODO:途中
stepGame : Input -> GameCondition -> GameCondition
stepGame input gameCondition =
    case gameCondition.state of
        Ready -> let fieldWidth = truncate gameCondition.fieldWidth
                     fieldHeight = truncate gameCondition.fieldHeight
                 in if | input.spaceKey -> { gameCondition |   state <- Init
                                                             , message <- "Start initialize."
                                                             , enemyFieldRectTypes <- Array.repeat (fieldWidth * fieldHeight) None
                                                             , playerFieldRectTypes <- Array.repeat (fieldWidth * fieldHeight) None }
                       | otherwise      -> gameCondition
        Init -> let enemyFieldRects = Array.toList gameCondition.enemyFieldRectTypes
                    playerFieldRects = Array.toList gameCondition.playerFieldRectTypes
                in { gameCondition | state <- PlayerTurn } -- TODO 戦艦、駆逐艦、潜水艦の配置を行うプロセスを追加
        PlayerTurn -> { gameCondition | state <- EnemyTurn }
        EnemyTurn -> { gameCondition | state <- PlayerTurn }
        Result -> { gameCondition | state <- Ready }

-- ゲーム状態シグナル
gameConditionSignal : Signal GameCondition
gameConditionSignal = foldp stepGame defaultGameCondition input

-- 船の自動配置 TODO 途中
autoDeployment : [FieldRectType] -> ShipType -> [FieldRectType]
autoDeployment fieldRectTypes shipType = fieldRectTypes

-- 各船の配置の確認を行う TODO 途中
checkDeployment : [FieldRectType] -> ShipType -> Bool
checkDeployment fieldRectTypes fieldRectType =
    case fieldRectType of
        BattleShip -> True
        Destroyer -> True
        Submarine -> True

-- ゲームのメイン関数
game : Input -> GameCondition -> (Int, Int) -> Element
game {xy, spaceKey} gameCondition (wx, wy) =
    let fieldRectTypes = Array.initialize (fieldWidth * fieldHeight) (always None)
        cursorRectType = if spaceKey then Attack else Selected
        fieldRectTypeList = Array.toList (Array.set (fst xy +snd xy * fieldWidth) cursorRectType fieldRectTypes)
        fieldGrids = fieldGrid gameCondition (0, 0) fieldRectTypeList []
        message = (toForm . centered . toText) gameCondition.message |> move (0, 300)
    in message :: fieldGrids |> collage wx wy

rectType : (Float, Float) -> [FieldRectType] -> Maybe FieldRectType
rectType (x, y) rects =
    let rectArray = Array.fromList rects
    in Array.get (truncate (x + y * fieldWidth)) rectArray

-- グリッド描画関数
fieldGrid : GameCondition -> (Float, Float) -> [FieldRectType] -> [Form] -> [Form]
fieldGrid gameCondition (x, y) rects forms =
     let fieldHeight = gameCondition.fieldHeight
         fieldWidth = gameCondition.fieldWidth
         cellWidth = gameCondition.cellWidth
         cellHeight = gameCondition.cellHeight
     in if | y == fieldHeight -> forms
           | x == fieldWidth -> -- xをリセット
              let x' = 0
                  y' = y + 1
              in fieldGrid gameCondition (x', y') rects (forms)
           | otherwise -> -- 標準の場合
              let fieldRectType = log "rectType" rectType (x, y) rects
                  form = fieldRect (cellWidth, cellHeight) (x, y) fieldRectType
                  x' = x + 1
                  y' = y
              in fieldGrid gameCondition (x', y') rects (form :: forms)

-- グリッドの枠線と中身を描画する関数
fieldRect : (Float, Float) -> (Float, Float) -> Maybe FieldRectType -> Form
fieldRect (cellWidth, cellHeight) (mx, my) fieldRectType =
    let lineStyle = solid lightGreen
        shp = rect cellWidth cellHeight
        width = cellWidth
        height = cellHeight
    in case fieldRectType of
        Just None -> outlined lineStyle shp |> move (mx * width, my * height)
        Just Selected -> filled lightGreen shp |> move (mx * width, my * height)
        Just Attack -> filled lightRed shp |> move (mx * width, my * height)
        Nothing -> outlined lineStyle shp |> move (mx * width, my * height)

-- メイン
main = game <~ input ~ dropRepeats gameConditionSignal ~ Window.dimensions