apecs_ascii_term_min.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Lib
    ( main
    ) where

import           Protolude
import           Apecs as Ap
import           Control.Exception.Safe (throwString)
import           Linear ( V2(..) )
import qualified System.Console.ANSI as A
import qualified System.Console.Terminal.Size as Sz
import qualified System.IO as IO

newtype Position = Position (V2 Int) deriving Show
instance Component Position where type Storage Position = Ap.Map Position

data Tile = Tile Char [A.SGR] deriving Show
instance Component Tile where type Storage Tile = Ap.Map Tile


data Pet = Pet
instance Component Pet where type Storage Pet = Ap.Map Pet

data Player = Player
instance Component Player where type Storage Player = Unique Player


Ap.makeWorld "World" [''Position, ''Pet, ''Player, ''Tile]


main :: IO ()
main = do
  IO.hSetEcho stdin False
  IO.hSetBuffering stdin IO.NoBuffering
  IO.hSetBuffering stdout IO.NoBuffering
  w <- initWorld
  runSystem game w


game :: System World ()
game = do
  Ap.newEntity (Position (V2 0 0), Pet, Tile 'c' [])
  Ap.newEntity (Position (V2 5 3), Pet, Tile 'd' [])
  Ap.newEntity (Position 1, Player, Tile '@' [A.SetColor A.Foreground A.Vivid A.Green])

  liftIO A.hideCursor
  go

  liftIO $ do
    A.setSGR [A.Reset]
    A.clearScreen
    A.showCursor

  where
    go = do
      liftIO $ do
        A.setSGR [A.Reset]
        A.clearScreen
        A.setCursorPosition 0 0
      cmapM_ $ \(Position p, t@Tile {}) -> liftIO $ drawEntity p t

      (stop, move) <-
        (liftIO getKey) >>= \case
          "q" -> pure (True, Nothing)
          "k" -> pure (False, Just (-1, 0))
          "j" -> pure (False, Just (1, 0))
          "l" -> pure (False, Just (0, 1))
          "h" -> pure (False, Just (0, -1))
          _   -> pure (False, Just (0, 0))

      if not stop
        then do
          case move of
            Nothing -> pass
            Just (dx, dy) -> cmap $ \(Position p, _ :: Player) -> Position (p + V2 dx dy)
          go
        else
          pass


drawEntity :: V2 Int -> Tile -> IO ()
drawEntity (V2 x y) (Tile t a) = do
  A.setCursorPosition x y
  A.setSGR [A.Reset]
  A.setSGR a
  putStr [t]


getTermSize :: IO (Int, Int)
getTermSize =
  Sz.size @ Int >>= \case
    Nothing -> throwString "unable to get screen size"
    Just (Sz.Window w h) -> pure (min 50 w, min 20 h)


-- | https://stackoverflow.com/questions/23068218/haskell-read-raw-keyboard-input
getKey :: IO [Char]
getKey = reverse <$> getKey' ""
  where getKey' chars = do
          char <- IO.getChar
          more <- IO.hReady stdin
          (if more then getKey' else return) (char:chars)