実装は途中

D-Island.md

D-Island

ようこそ "D-Island" へ！ あなたはとても楽しいゲームに参加する権利を得た幸運な人です. ゲームは簡単, 相手を欺いて生き残るだけです. さらに幸運なことに, あなたには特別な武器まで差し上げます. もちろん, たださし上げるだけでは面白くありませんから, キチンと条件もつけておいてあげます. あなたほどの人なら, ペナルティなど受けるはずもありませんね.

そうそう, まだ不確定な情報なのですが, 手違いでゲームにはミュータント(突然変異種)が紛れ込んでいるようです. くれぐれもお気をつけて.

必要なもの

• プレイヤー(3人以上)
• ボードおよびコマ
• ライフ・体力を表示するためのチップ
• 手札カード
• 武器カード・MTカード

ゲームの手順

ゲームは以下のような順番で進む

• ゲームセット
  • カードの分配
  • ステータス・クリア条件の確認
• ゲーム中
  1. コマの移動・配置
  2. アクションカードを1枚選び場に伏せる(このとき同盟を組んでいる仲間と情報交換をしてもよい)
  3. オープン
  4. MTカードの発動(希望があれば)
  5. アクションを実行(交渉→攻撃→移動の順番)
  6. ダメージ計算・死亡判定
  7. ボードのマスを削る
  8. 1に戻る
• 終了時
  • クリア判定, ストックの計算
  • 勝敗の判定

カードの分配

各プレイヤーは以下を受け取る

• ライフストック ライフの数だけ
• アクションカード 攻撃・移動・交渉 2枚ずつ
• 武器カード 1枚
• MTカード 1枚
• ボードで使うコマ 1体

ステータス・クリア条件の確認

初期ステータスは以下の通り

• ライフ 5 (ライフが0以下になるとゲームから除かれる)
• 体力 1ライフあたり5ポイント (ポイントが0以下になると死亡する)
• 武器 武器カードに従う
• MT能力 MTカードに従う
• コマ ボード上の終点(中央のマス)に置く

クリア条件は以下の通り

• 全てのターン終了時にライフが1以上 (体力ポイントが1以上)
• 武器カードのポイント数条件をクリアする
• 武器カードにあるクリア条件をクリアする (オプション; このルールは無効にしてもよい)

以上の条件が揃わなくても, 終了時に後述のペナルティを支払うことでクリア判定に参加することができる (クリア判定を見よ)

MTカード

MTカードはアクションカードをオープンした直後に発動を宣言してもよい. 使用したMTカードは破棄する. (ゲーム中1度しか使用できない)

アクションフェイズ

アクションカードの選択, オープン, アクションの実行, コマの移動までをアクションフェイズとよぶ. アクションは必ず交渉→攻撃→移動の順番で行う.

アクションフェイズで使用したアクションカードはターンの終わりに破棄する. 3ターンごとに手札のアクションカードを補充する (攻撃・移動・交渉をそれぞれ2枚ずつ).

交渉

選んだ相手1人に対し, 交渉して 同盟 を結ぶ. (ボード上で同じマスにいなくてよい) 交渉を持ちかけた方を リーダー とよぶ. (双方が互いに交渉を持ちかけた場合はプレイヤーがリーダーを決めてよい)

同盟関係の結成

• プレイヤーは交渉された時, 同盟を結ぶかどうか選んで良い. 同盟はちょうど2名のプレイヤーをメンバーとして含む.
• プレイヤーは2人以上と同盟を結んでもよい.
• 一度同盟のリーダーになったプレイヤーは, 仲間として別のプレイヤーと同盟を結ぶことはできない.

例) プレイヤーAがBへ交渉, BがCへ交渉, DがCへ交渉しているとき, 全員が同盟を結んだ場合, 「A(リーダー), B」と「B(リーダー), C」と「D(リーダー), C」の3組の同盟ができる.

アクションフェイズ開始時に同盟関係にあるプレイヤーは以下に従う

1. アクションカードの選択時, 同盟関係にあるリーダーは, 手札からアクションカードを2枚伏せ, 同盟関係にある仲間に渡す. 渡された仲間はリーダーの出すアクションカードを選択できる.
2. 同盟を結んでいるプレイヤーはリーダーの処理より仲間の処理を優先する.
3. 仲間はアクションカードの選択に制限を受けない. (リーダーの出すアクションカードと同じカードを出してもよいし, 出さなくてもよい)
4. アクションカードのオープン時, 同盟関係にあるプレイヤーのアクションカードが異なる場合, その同盟は破棄される.
5. アクションカードのオープン時, 同盟関係にあるプレイヤーのアクションカードが一致する場合, そのターンのアクション内容は全てリーダーが決定する.
6. アクションフェイズの終了時, 同盟のメンバーは自分の属する同盟関係を破棄することができる.

攻撃

ボード上で同じマスにいる相手を1人選び, 武器カードのポイント分だけ相手の体力ポイントを減らす. 攻撃時に武器カードを公開する必要はない.

攻撃した相手が同盟関係にある場合, 以下に従う

• 攻撃のダメージ(武器カードのポイント)は同盟に含まれるプレイヤーで均等に割り振る. 端数はリーダーが請け負う.

攻撃するプレイヤーが同盟関係にある場合, 以下に従う

• 攻撃するプレイヤーが同盟関係にある場合(すなわち, リーダーが攻撃する場合), 同盟関係にあるプレイヤーの攻撃ポイントを合算した値が相手へのダメージになる.

移動

ボード上2マスまで移動できる.

ボードのマスを削る

アクションフェイズが終了した後, プレイヤーはボード上のマスを1つ選ぶ. このマスを次のターンの終了時に削る (立入禁止にする). マスを削る瞬間にそこにいたプレイヤーは死亡し, ライフを1減らす. マスを削る権利はプレイヤーに順番に回す.

ゲーム終了時

各プレイヤーは以下のペナルティを受けた上で, 精算を行う. 残りライフ・体力の多いプレイヤーが勝利する.

ペナルティ

• 残りライフのないもの(ライフが0以下のもの)は無条件で負け
• 相手から削ったポイント数と武器カードのポイント数の差だけライフを減らす
• 武器カードにあるクリア条件をクリアできなかった場合, ライフを1減らす (オプション; このルールは無効にしてもよい)

ボード(見取り図)

プレイヤー人数に応じて以下のルールにしたがって用意する

• 中央に破壊不可能なマスを置く (終点)
• マスの数はターンの数以上にする

武器カード

ゲームバランスによっては変更しても良いし, 同じ武器カードを複数枚用意してもよい.

武器	武器ポイント	クリア条件
拳銃	4	3人以上のプレイヤーからライフを奪う
手榴弾	4	MTカードを使用しない
チェーンソー	3
火炎瓶	3
ボウガン	2	三度以上, 同盟のリーダーになる
果物ナイフ	2	二度以上, 同盟を結んでいる相手に攻撃する
スタンガン	2	同時に2組以上の同盟に属する
アイスピック	1	一度も同盟に属さない

MTカード

ゲームバランスによっては変更しても良い

• アドレナリン調整; Adrenaline Control (このターン, 発動者は攻撃力または体力を, 合計3ポイントまで上昇させる. 体力が5ポイントを超えて補正することもできるがターンの終わりに体力を元に戻す)
• チャーム; Charm (このターン, 選んだ相手のアクションカードを破棄し, 発動者は新たに相手のアクションを選びなおす. ただしアクションの内容には干渉できない)
• エナジーフィールド; Energy field (このターン, 発動者は一切のダメージを受けない)
• 機械感応; Machine Empathy (このターン, 発動者は選んだ相手と武器を交換することができる)
• 悪食; Matter eater (このターン, 発動者は同じマスにいる相手の攻撃を無効にする. ただし自分が対象でない攻撃を無効にするかどうかは発動者が選んでよい)
• 形態変化; Polymorphism (このターン, 発動者は選んだ相手と位置を入れ替える. 相手が同じマスにいる場合, このターンの全ての攻撃および交渉対象を入れ替える)
• テレキネシス; Telekinesis (発動時に選んだ相手の位置を2マスまで移動させることができる)
• テレポート; Teleportation (発動宣言時にテレポートするマスを選ぶ. このターン, 発動者は他のプレイヤーから一切の干渉を受けない)

効果の不明なカード

• 魅了; Deep Probe
• 電撃; Electroshock
• 感応; Empathy
• 超感覚; Hypersenses
• 浮遊; Levitate
• メンタルブラスト; Mental Blast
• 予知能力; Precognition
• パイロキネシス; Pyrokenisis

DIsland.hs

{-# LANGUAGE GADTs, MultiWayIf, PackageImports #-}
import Haste
import Haste.Concurrent
import qualified Haste.Perch as P
import Objective
import Lens
import Lens.Family2 hiding (ix, at)
import Lens.Family2.Unchecked
import Lens.Family2.State.Strict
import Control.Applicative
import "mtl" Control.Monad.State.Strict
import qualified Data.IntMap as M
import Data.Ord (comparing)
import Data.List (delete, sortBy)

consMap :: a -> M.IntMap a -> (Int, M.IntMap a)
consMap x m
  | M.size m == 0 = (0, m & at 0 ?~ x)
  | otherwise = let (i,_) = M.findMax m in (i+1, m & at (i+1) ?~ x)

data Weapon = Handgun | Grenade | StunGun deriving (Eq, Show)

damage :: Weapon -> Int
damage Handgun = 3
damage Grenade = 3
damage StunGun = 2

data Player = Player {
  _life :: Int,
  _lPoint :: Int,
  _mt :: (),
  _equip :: Weapon,
  _position :: Int
} deriving (Show)

data GameValue = GameValue {
  _board :: M.IntMap [Int],
  _players :: M.IntMap Player,
  _allies :: [(Int,Int)],
  _turn :: Int
}

life :: Lens' Player Int; life = lens _life (\p x -> p { _life = x })
lPoint :: Lens' Player Int; lPoint = lens _lPoint (\p x -> p { _lPoint = x })
mt :: Lens' Player (); mt = lens _mt (\p x -> p { _mt = x })
equip :: Lens' Player Weapon; equip = lens _equip (\p x -> p { _equip = x })
position :: Lens' Player Int; position = lens _position (\p x -> p { _position = x })

board :: Lens' GameValue (M.IntMap [Int]); board = lens _board (\p x -> p { _board = x })
players :: Lens' GameValue (M.IntMap Player); players = lens _players (\p x -> p { _players = x })
allies :: Lens' GameValue [(Int,Int)]; allies = lens _allies (\p x -> p { _allies = x })
turn :: Lens' GameValue Int; turn = lens _turn (\p x -> p { _turn = x })

data Action = Negotiate | Attack | Move deriving (Eq, Show, Ord)

data Dealer a where
  Init :: Dealer ()
  Print :: Dealer ()
  Battle :: Int -> Int -> Dealer ()
  MovePlayer :: Int -> Int -> Dealer ()
  Negotiation :: Int -> Int -> Dealer ()
  Calc :: Dealer ()
  NewTurn :: Dealer Bool
  Add :: Player -> Dealer ()
  UpdateAlly :: M.IntMap Action -> Dealer [(Int,Int)]

dealer :: Object Dealer IO
dealer = stateful run initGame where
  initGame = GameValue
    (M.fromList $ zip [0..] [[],[],[],[],[]])
    M.empty
    []
    0

  battle :: [Int] -> [Int] -> StateT GameValue IO ()
  battle as bs = do
    ps <- use players
    return ()
    let d = sum $ (\a -> damage $ ps ^?! ix a ^. equip) <$> as
    let dbs = replicate (length bs) (d `mod` length bs) & ix 0 +~ (d - d `mod` length bs * length bs)
    forM_ (zip bs dbs) $ \(b,db) -> do
      players . ix b . lPoint -= db

  run :: Dealer a -> StateT GameValue IO a
  run Init = put initGame
  run (Add p) = do
    ps <- use players
    let (n, ps') = consMap p ps
    players .= ps'
    board %= (at (p^.position) ?%~ (n:))
  run Print = do
    use turn >>= \t -> lift . withElem "turn-number" $ P.build $ P.setHtml P.this "" >> P.toElem t
    use players >>= \ps -> lift . withElem "player-data" $ P.build $ do
      P.setHtml P.this ""
      forM_ (M.assocs ps) $ \(i,p) -> do
        P.div $ do
          P.toElem $ "player No." ++ show i ++ " "
          P.toElem $ "life: " ++ (take (p^.life) $ repeat '●') ++ " "
          P.toElem $ "lPoint: " ++ (take (p^.lPoint) $ repeat '●')
    use board >>= \b -> lift . withElem "board-display" . P.build $ P.setHtml P.this "" >> (P.toElem . show $ b)
    use allies >>= \as -> lift . withElem "allies" . P.build $ P.setHtml P.this "" >> (P.toElem . show $ as)
    return ()
  run (Battle s t) = do
    lift $ putStrLn $ "attack " ++ show s ++ " to " ++ show t
    as <- use allies
    ps <- use players
    case (ps ^?! ix s ^. position == ps ^?! ix t ^. position) of
      True -> do
        battle
          (s : (snd <$> filter (\x -> fst x == s) as))
          (t : (fst <$> filter (\x -> snd x == t) as))
      False -> lift $ putStrLn $ "miss!"
  run (MovePlayer p i) = do
    lift $ putStrLn $ "move " ++ show p ++ " to " ++ show i
    now <- use players <&> (\x -> x ^?! ix p ^. position)
    board . ix now %= delete p
    board . ix i %= (p:)
    players . ix now . position .= i
  run (Negotiation s t) = do
    lift $ putStrLn $ "negotiate " ++ show s ++ " to " ++ show t
    allies %= ((s,t) :)
  run Calc = do
    players . each %= (\p -> if p^.lPoint > 0 then p else p & life -~ 1 & lPoint .~ 5)
  run NewTurn = do
    turn += 1
    (&&) <$> (use turn <&> (<= 5)) <*> (use players <&> all (\p -> p ^. life > 0) . M.elems)
  run (UpdateAlly actions) = do
--    allies %= filter (\(s,t) -> actions ^?! ix s == actions ^?! ix t)
    use allies

data Play a where
  GetAction :: Play Action
  MakeAction :: (Action -> IO ()) -> Play ()
  RunAction :: Action -> Inst IO Dealer IO -> Int -> Play ()
  ActionTarget :: Action -> (Int -> IO ()) -> Play ()

cpu :: Object Play IO
cpu = liftO run where
  run :: Play a -> IO a
  run GetAction = return Attack
  run (RunAction act d k) = do
    r <- head . filter (/= k) . randomRs (0,3) <$> newSeed
    case act of
      Attack -> d .- Battle k r
      Move -> d .- MovePlayer k r
      Negotiate -> d .- Negotiation k r

player :: Object Play IO
player = liftO run where
  actionButton m s = P.button $ do
    P.toElem $ show s
    P.addEvent P.this OnClick $ \_ _ -> do
      withElem "action-cards" $ P.build $ P.setHtml P.this ""
      m s
  targetButton m s = P.button $ do
    P.toElem $ show s
    P.addEvent P.this OnClick $ \_ _ -> do
      withElem "target-buttons" $ P.build $ P.setHtml P.this ""
      m s

  run :: Play a -> IO a
  run (MakeAction m) = do
    void $ withElem "action-cards" $ P.build $ do
      mapM_ (actionButton m) [Attack, Move, Negotiate]
  run (RunAction act d k) = do
    case act of
      Attack -> d .- Battle 0 k
      Move -> d .- MovePlayer 0 k
      Negotiate -> d .- Negotiation 0 k
  run (ActionTarget act m) = do
    void $ withElem "target-buttons" $ P.build $ do
      case act of
        Move -> mapM_ (targetButton m) [0..4]
        _ -> mapM_ (targetButton m) [1..3]

mainloop :: Inst IO Dealer IO -> M.IntMap (Inst IO Play IO) -> IO ()
mainloop d ps = do
  d .- Print

  eacts <- traverseOf id (.- GetAction) $ M.filterWithKey (\k _ -> k > 0) ps
  call (ps ^?! ix 0) $ MakeAction $ \act -> do
    let actions = eacts & at 0 ?~ act
    as <- d .- UpdateAlly actions

    let (qs, r:rs) = span (\a -> fst a /= 0) $ sortBy (comparing snd) $ filter (\a -> fst a `notElem` fmap snd as) $ M.assocs actions
    forM_ qs $ \(k,act) -> (ps ^?! ix k) .- RunAction act d k
    call (ps ^?! ix 0) $ ActionTarget (snd r) $ \i -> do
      (ps ^?! ix 0) .- RunAction (snd r) d i
      forM_ rs $ \(k,act) -> (ps ^?! ix k) .- RunAction act d k

      d .- Calc
      d .- Print

      q <- d .- NewTurn
      when q $ setTimeout 500 $ mainloop d ps

main = do
  d <- new dealer
  p <- new player
  c <- new cpu

  d .- Add (Player 4 5 () Handgun 0)
  d .- Add (Player 4 5 () Grenade 0)
  d .- Add (Player 4 5 () Grenade 0)
  d .- Add (Player 4 5 () StunGun 0)

  mainloop d $ M.fromList $ zip [0..] [p,c,c,c]

Lens.hs

{-# LANGUAGE RankNTypes, MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
module Lens where

import Lens.Family2
import Lens.Family2.Unchecked
import Lens.Family2.Stock
import Lens.Family2.State.Strict
import Control.Applicative
import qualified Data.IntMap as M
import qualified Data.Traversable as T
import Data.Maybe (fromJust)
import Data.Monoid

infixr 4 ?~
(?~) :: Setter s t a (Maybe b) -> b -> s -> t
l ?~ t = set l (Just t)

infixl 1 <&>
(<&>) :: Functor f => f a -> (a -> b) -> f b
(<&>) = flip (<$>)

(?%~) :: Setter s t (Maybe a) (Maybe b) -> (a -> b) -> s -> t
l ?%~ f = l %~ (<&> f)

infixl 8 ^?!
(^?!) :: s -> Traversal' s a -> a
s ^?! l = fromJust $ getFirst $ getConst $ l (Const . First . Just) s

each :: Traversal' (M.IntMap a) a
each = T.traverse

traverseOf _ f x = T.mapM f x

type family IxValue m where
  IxValue [a] = a
  IxValue (M.IntMap a) = a

class Ixed m where
  ix :: Int -> Traversal' m (IxValue m)

instance Ixed [a] where
  ix k f xs0
    | k < 0 = pure xs0
    | otherwise = go xs0 k where
        go [] _ = pure []
        go (a:as) 0 = (:as) <$> f a
        go (a:as) i = (a:) <$> (go as $! i - 1)

instance Ixed (M.IntMap a) where
  ix k f m = case M.lookup k m of
    Just v -> f v <&> \v' -> M.insert k v' m
    Nothing -> pure m

class Ixed m => At m where
  at :: Int -> Lens' m (Maybe (IxValue m))

instance At (M.IntMap a) where
  at k f m = f mv <&> \r -> case r of
    Just v' -> M.insert k v' m
    Nothing -> maybe m (const (M.delete k m)) mv
    where mv = M.lookup k m

Objective.hs

{-# LANGUAGE Rank2Types, KindSignatures, TypeFamilies, ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Objective where

import Data.OpenUnion1.Clean
import Control.Arrow
import Control.Monad
import Control.Monad.Trans.State.Strict
import Control.Elevator
import Control.Concurrent

newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }

liftO :: Functor g => (forall x. f x -> g x) -> Object f g
liftO f = go where go = Object $ fmap (\x -> (x, go)) . f

stateful :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object f m
stateful h = go where
  go s = Object $ liftM (second go) . flip runStateT s . h

type Inst' f g = Inst g f g

class Monad b => ObjectiveBase b where
  data Inst b (f :: * -> *) (g :: * -> *)
  new :: Object f g -> b (Inst b f g)
  invoke :: Monad m => (forall x. b x -> m x) -> (forall x. g x -> m x) -> Inst b f g -> f a -> m a

instance ObjectiveBase IO where
  data Inst IO f g = InstIO (MVar (Object f g))
  new v = InstIO `fmap` newMVar v
  invoke mr gr (InstIO m) e = do
    c <- mr $ takeMVar m
    (a,c') <- gr $ runObject c e
    mr $ putMVar m c'
    return a

type MonadObjective b m = (ObjectiveBase b, Elevate b m, Monad m)

infixr 3 .-
(.-) :: (MonadObjective b m, Elevate g m) => Inst b f g -> f a -> m a
(.-) = invoke elevate elevate

call :: (MonadObjective b m, Elevate g m) => Inst b f g -> f a -> m a
call = (.-)