<commit_before>{-# LANGUAGE OverloadedStrings, GADTs, ViewPatterns #-}

module Crawl.Move (
  Move(..), sendMoves
  ) where

import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Monad.Operational (Program, singleton, view, ProgramViewT(..))

import qualified Data.Text as T
import qualified Reactive.Banana as R

import Crawl.Bindings
import Crawl.Inventory
import Crawl.Item
import Crawl.Messages
import Crawl.Menu
import Crawl.ParseItem

data Move = Go !Int !Int
          | Attack !Int !Int
          | Berserk
          | TrogsHand
          | BurnBooks
          | GoUp
          | GoDown
          | Rest
          | LongRest
          | PickUp (Item -> Bool)
          | AutoExplore
          | AutoFight
          | Butcher
          | Pray
          | Drop InventorySlot
          | Eat InventorySlot
          | Wield InventorySlot
          | Wear InventorySlot
          | TakeOff InventorySlot
          | Quaff InventorySlot
          | Read InventorySlot
          | ScanBigStack
          | ScanItem !Int !Int
          | LookHere
          | Dump


data SendOp a where
  Press :: T.Text -> SendOp ()
  ExpectPrompt :: T.Text -> SendOp ()
  ExpectMenu :: (T.Text -> Bool) -> SendOp ()
  SetPickupFunc :: (Item -> Bool) -> SendOp ()
  AnswerYesNo :: T.Text -> SendOp ()

type Send = Program SendOp

press :: T.Text -> Send ()
press = singleton . Press

expectPrompt :: T.Text -> Send ()
expectPrompt = singleton . ExpectPrompt

expectMenu :: (T.Text -> Bool) -> Send ()
expectMenu = singleton . ExpectMenu

setPickupFunc :: (Item -> Bool) -> Send ()
setPickupFunc = singleton . SetPickupFunc

answerYesNo :: T.Text -> Send ()
answerYesNo = singleton . AnswerYesNo


moveProgram :: Move -> Send ()
moveProgram (Go dx dy) = press $ case (dx, dy) of
  (-1,  0) -> "h"
  ( 0,  1) -> "j"
  ( 0, -1) -> "k"
  ( 1,  0) -> "l"
  (-1, -1) -> "y"
  ( 1, -1) -> "u"
  (-1,  1) -> "b"
  ( 1,  1) -> "n"
  _        -> error "tried to make illegal move"
moveProgram (Attack dx dy) = press $ case (dx, dy) of
  (-1,  0) -> "\8"
  ( 0,  1) -> "\10"
  ( 0, -1) -> "\11"
  ( 1,  0) -> "\12"
  (-1, -1) -> "\25"
  ( 1, -1) -> "\21"
  (-1,  1) -> "\2"
  ( 1,  1) -> "\14"
  _        -> error "tried to make illegal attack"
moveProgram Berserk = useAbility "a"
moveProgram TrogsHand = useAbility "b"
moveProgram BurnBooks = useAbility "f"
moveProgram GoUp = press "<"
moveProgram GoDown = press ">"
moveProgram Rest = press "."
moveProgram (PickUp f) = press "," >> setPickupFunc f
moveProgram LongRest = press "5"
moveProgram AutoExplore = press "o"
moveProgram AutoFight = press "\t"
moveProgram Butcher = press "c"
moveProgram Pray = press "p"
moveProgram (Drop slot) = do
  press "d"
  expectMenu ("<white>Drop what? " `T.isPrefixOf`)
  press (T.singleton $ slotLetter slot)
  press "\r"
moveProgram (Eat slot) = do
  press "e"
  expectMenu (== "<white>Eat which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (Wield slot) = do
  press "w"
  expectMenu (== "<white>Wield which item (- for none, * to show all)?")
  press (T.singleton $ slotLetter slot)
moveProgram (Wear slot) = do
  press "W"
  expectMenu (== "<white>Wear which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (TakeOff slot) = do
  press "T"
  expectMenu (== "<white>Take off which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (Quaff slot) = do
  press "q"
  expectMenu (== "<white>Drink which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (Read slot) = do
  press "r"
  expectMenu (== "<white>Read which item?")
  press (T.singleton $ slotLetter slot)
moveProgram ScanBigStack = moveProgram (PickUp (const False))
moveProgram (ScanItem dx dy) = do
  -- todo: send this all in a single message
  press "x"
  let go 0 0 = return ()
      go rx ry = moveProgram (Go sx sy) >> go (rx - sx) (ry - sy)
        where sx = signum rx
              sy = signum ry
  go dx dy
  press "\ESC"
moveProgram LookHere = press ";"
moveProgram Dump = press "#"

useAbility :: T.Text -> Send ()
useAbility a = do
  press "a"
  expectPrompt "<cyan>Use which ability? (? or * to list) <lightgrey>"
  press a


sendMoves :: R.Behavior t Move -> R.Event t Message -> R.Event t MouseMode -> R.Event t Menu -> (R.Event t Move, R.Event t T.Text)
sendMoves move messages inputModeChanged menu
  = R.split $ R.spill . fst $
    R.mapAccum (return ())
    ((handleMessage . _msgText <$> messages) `R.union` (handleInputMode <$> move R.<@> inputModeChanged)
    `R.union` (handleMenu <$> menu))
  where handleMessage :: T.Text -> Send () -> ([Either Move T.Text], Send ())
        handleMessage message prog
          | "<cyan>Eat " `T.isPrefixOf` message && " (ye/n/q/i?)<lightgrey>" `T.isSuffixOf` message = ([Right "n"], prog) -- ew, don't eat off the ground
        handleMessage
          (T.stripPrefix "<cyan>Pick up " ->
           Just (T.stripSuffix "? ((y)es/(n)o/(a)ll/(m)enu/*?g,/q)<lightgrey>" -> Just itemName)) prog =
            ([], answerYesNo itemName >> prog)
        handleMessage "<cyan>Increase (S)trength, (I)ntelligence, or (D)exterity? <lightgrey>" prog
          = ([], press "s" >> prog)
        handleMessage message prog
          | "<cyan>Butcher " `T.isPrefixOf` message = ([Right "a"], prog)
        handleMessage "<cyan>Blink to where?<lightgrey>" prog = ([Right "\ESC"], prog)
        handleMessage "<cyan>What kind of item would you like to acquire? (\\ to view known items)<lightgrey>" prog = ([], press "b" >> prog)
        handleMessage message prog = (,) [] $ case view prog of
          ExpectPrompt m :>>= prog' | message == m -> prog' ()
          _ -> prog
        handleInputMode :: Move -> MouseMode -> Send () -> ([Either Move T.Text], Send ())<commit_msg>Update useAbility for ability menu always appearing<commit_after>{-# LANGUAGE OverloadedStrings, GADTs, ViewPatterns #-}

module Crawl.Move (
  Move(..), sendMoves
  ) where

import Control.Applicative ((<$>))
import Control.Arrow (first)
import Control.Monad.Operational (Program, singleton, view, ProgramViewT(..))

import qualified Data.Text as T
import qualified Reactive.Banana as R

import Crawl.Bindings
import Crawl.Inventory
import Crawl.Item
import Crawl.Messages
import Crawl.Menu
import Crawl.ParseItem

data Move = Go !Int !Int
          | Attack !Int !Int
          | Berserk
          | TrogsHand
          | BurnBooks
          | GoUp
          | GoDown
          | Rest
          | LongRest
          | PickUp (Item -> Bool)
          | AutoExplore
          | AutoFight
          | Butcher
          | Pray
          | Drop InventorySlot
          | Eat InventorySlot
          | Wield InventorySlot
          | Wear InventorySlot
          | TakeOff InventorySlot
          | Quaff InventorySlot
          | Read InventorySlot
          | ScanBigStack
          | ScanItem !Int !Int
          | LookHere
          | Dump


data SendOp a where
  Press :: T.Text -> SendOp ()
  ExpectPrompt :: T.Text -> SendOp ()
  ExpectMenu :: (T.Text -> Bool) -> SendOp ()
  SetPickupFunc :: (Item -> Bool) -> SendOp ()
  AnswerYesNo :: T.Text -> SendOp ()

type Send = Program SendOp

press :: T.Text -> Send ()
press = singleton . Press

_expectPrompt :: T.Text -> Send ()
_expectPrompt = singleton . ExpectPrompt

expectMenu :: (T.Text -> Bool) -> Send ()
expectMenu = singleton . ExpectMenu

setPickupFunc :: (Item -> Bool) -> Send ()
setPickupFunc = singleton . SetPickupFunc

answerYesNo :: T.Text -> Send ()
answerYesNo = singleton . AnswerYesNo


moveProgram :: Move -> Send ()
moveProgram (Go dx dy) = press $ case (dx, dy) of
  (-1,  0) -> "h"
  ( 0,  1) -> "j"
  ( 0, -1) -> "k"
  ( 1,  0) -> "l"
  (-1, -1) -> "y"
  ( 1, -1) -> "u"
  (-1,  1) -> "b"
  ( 1,  1) -> "n"
  _        -> error "tried to make illegal move"
moveProgram (Attack dx dy) = press $ case (dx, dy) of
  (-1,  0) -> "\8"
  ( 0,  1) -> "\10"
  ( 0, -1) -> "\11"
  ( 1,  0) -> "\12"
  (-1, -1) -> "\25"
  ( 1, -1) -> "\21"
  (-1,  1) -> "\2"
  ( 1,  1) -> "\14"
  _        -> error "tried to make illegal attack"
moveProgram Berserk = useAbility "a"
moveProgram TrogsHand = useAbility "b"
moveProgram BurnBooks = useAbility "f"
moveProgram GoUp = press "<"
moveProgram GoDown = press ">"
moveProgram Rest = press "."
moveProgram (PickUp f) = press "," >> setPickupFunc f
moveProgram LongRest = press "5"
moveProgram AutoExplore = press "o"
moveProgram AutoFight = press "\t"
moveProgram Butcher = press "c"
moveProgram Pray = press "p"
moveProgram (Drop slot) = do
  press "d"
  expectMenu ("<white>Drop what? " `T.isPrefixOf`)
  press (T.singleton $ slotLetter slot)
  press "\r"
moveProgram (Eat slot) = do
  press "e"
  expectMenu (== "<white>Eat which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (Wield slot) = do
  press "w"
  expectMenu (== "<white>Wield which item (- for none, * to show all)?")
  press (T.singleton $ slotLetter slot)
moveProgram (Wear slot) = do
  press "W"
  expectMenu (== "<white>Wear which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (TakeOff slot) = do
  press "T"
  expectMenu (== "<white>Take off which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (Quaff slot) = do
  press "q"
  expectMenu (== "<white>Drink which item?")
  press (T.singleton $ slotLetter slot)
moveProgram (Read slot) = do
  press "r"
  expectMenu (== "<white>Read which item?")
  press (T.singleton $ slotLetter slot)
moveProgram ScanBigStack = moveProgram (PickUp (const False))
moveProgram (ScanItem dx dy) = do
  -- todo: send this all in a single message
  press "x"
  let go 0 0 = return ()
      go rx ry = moveProgram (Go sx sy) >> go (rx - sx) (ry - sy)
        where sx = signum rx
              sy = signum ry
  go dx dy
  press "\ESC"
moveProgram LookHere = press ";"
moveProgram Dump = press "#"

useAbility :: T.Text -> Send ()
useAbility a = do
  press "a"
  expectMenu (T.isPrefixOf "<white>  Ability - do what?")
  press a


sendMoves :: R.Behavior t Move -> R.Event t Message -> R.Event t MouseMode -> R.Event t Menu -> (R.Event t Move, R.Event t T.Text)
sendMoves move messages inputModeChanged menu
  = R.split $ R.spill . fst $
    R.mapAccum (return ())
    ((handleMessage . _msgText <$> messages) `R.union` (handleInputMode <$> move R.<@> inputModeChanged)
    `R.union` (handleMenu <$> menu))
  where handleMessage :: T.Text -> Send () -> ([Either Move T.Text], Send ())
        handleMessage message prog
          | "<cyan>Eat " `T.isPrefixOf` message && " (ye/n/q/i?)<lightgrey>" `T.isSuffixOf` message = ([Right "n"], prog) -- ew, don't eat off the ground
        handleMessage
          (T.stripPrefix "<cyan>Pick up " ->
           Just (T.stripSuffix "? ((y)es/(n)o/(a)ll/(m)enu/*?g,/q)<lightgrey>" -> Just itemName)) prog =
            ([], answerYesNo itemName >> prog)
        handleMessage "<cyan>Increase (S)trength, (I)ntelligence, or (D)exterity? <lightgrey>" prog
          = ([], press "s" >> prog)
        handleMessage message prog
          | "<cyan>Butcher " `T.isPrefixOf` message = ([Right "a"], prog)
        handleMessage "<cyan>Blink to where?<lightgrey>" prog = ([Right "\ESC"], prog)
        handleMessage "<cyan>What kind of item would you like to acquire? (\\ to view known items)<lightgrey>" prog = ([], press "b" >> prog)
        handleMessage message prog = (,) [] $ case view prog of
          ExpectPrompt m :>>= prog' | message == m -> prog' ()
          _ -> prog
        handleInputMode :: Move -> MouseMode -> Send () -> ([Either Move T.Text], Send ())
{'fraction_non_alphanumeric': 0.14877474492020581, 'fraction_numerical': 0.008546263190023546, 'mean_word_length': 2.653392800254858, 'pattern_counts': {'":': 0, '<': 54, '<?xml version=': 0, '>': 174, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1298163', 'n_tokens_mistral': 4021, 'n_tokens_neox': 3821, 'n_words': 1198}