curses set game

root / Util.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
{-# LANGUAGE DeriveDataTypeable #-}
module Util (
    swp,
    pull, repl, count, generate, update,
    maximumWith, minimumWith,
    (>>=.), (>>.), (>>-), nop,
    repM, whileM, whileMJust, whileJustM,
    valLabel, labelVal,
    Rangeable(
      _range, _inRange, _index,
      allOf, rangeOf
    ),
    invArray,
    mods, unmod,
    quotRemainder,
    Exception(..), gameError, gameOver
    ) where

import qualified Control.Exception
import qualified Data.Typeable
import qualified Data.List as List
import qualified Data.Array as Array
import qualified Data.Char as Char
import qualified Data.Ix as Ix

swp :: (a,b) -> (b,a)
swp (a,b) = (b,a)

pull :: [a] -> Int -> (a, [a])
pull l n = get n l [] where
  get 0 (x:l) r = (x, r ++ l)
  get n (x:l) r = get (pred n) l (x:r)
  get _ [] _ = error "pull: index too large"

repl :: [a] -> Int -> a -> [a]
repl (_:l) 0 a = a:l
repl (x:l) n a = x : repl l (pred n) a
repl [] 0 a = [a]
repl [] _ _ = error "repl: index too large"

count :: (a -> Bool) -> [a] -> Int
count f = cnt where
  cnt [] = 0
  cnt (x:l)
    | f x = succ r
    | otherwise = r
    where r = cnt l

generate :: (a -> (b, a)) -> a -> [b]
generate f a = b : generate f a'
  where (b, a') = f a

update :: a -> (a -> a) -> Int -> [a] -> [a]
update z f = adj where
  adj n (x:l) = up n x l
  adj n [] = up n z []
  up 0 x l = f x:l
  up n x l = x:adj (pred n) l

maximumWith, minimumWith :: Ord b => (a -> b) -> [a] -> a
map_compare f x y = compare (f x) (f y)
maximumWith f = List.maximumBy (map_compare f)
minimumWith f = List.minimumBy (map_compare f)

infixl 1 >>=., >>.
(>>=.) :: Monad m => m a -> (a -> b) -> m b -- like liftM or fmap but with nicer syntax
(>>.) :: Monad m => m a -> b -> m b
(>>=.) e r = e >>= return . r
(>>.) e r = e >> return r

infixr 2 >>-
(>>-) :: Monad m => m () -> (a -> m b) -> a -> m b
(>>-) e f x = e >> f x

nop :: Monad m => m ()
nop = return ()

repM :: Monad m => Int -> (a -> m a) -> a -> m a
repM 0 _ x = return x
repM n f x = f x >>= repM (pred n) f

whileM :: Monad m => (a -> Bool) -> (a -> m a) -> a -> m a
whileM q f = while where
  while x
    | q x = f x >>= while
    | otherwise = return x

whileMJust :: Monad m => (a -> m (Maybe a)) -> a -> m ()
whileMJust f x = f x >>= maybe nop (whileMJust f)

whileJustM :: Monad m => (a -> Maybe (m a)) -> a -> m a
whileJustM f x = maybe (return x) (>>= whileJustM f) $ f x 

ca = Char.ord 'a' 
cA = Char.ord 'A'

valLabel :: Int -> Char
valLabel n
  | n < 26 = Char.chr (n + ca)
  | n < 52 = Char.chr (n + cA - 26)
  | otherwise = error "valLabel: index too large"

labelVal :: Char -> Int
labelVal ch
  | c >= ca && c < ca + 26 = c - ca
  | c >= cA && c < cA + 26 = c - cA + 26
  | otherwise = error "labelVal: invalid label"
  where
    c = Char.ord ch

class (Ord a, Enum a, Bounded a, Show a) => Rangeable a where
  _range :: (a,a) -> [a]
  _range = uncurry enumFromTo
  _inRange :: (a,a) -> a -> Bool
  _inRange (x,y) c = c >= x && c <= y
  _index :: (a,a) -> a -> Int
  _index r@(x,y) c | c >= x && c <= y = fromEnum c - fromEnum x
    | otherwise = error ("Index (" ++ show c ++ ") out of range (" ++ show r ++ ")")

  rangeOf :: (a,a)
  rangeOf = (minBound, maxBound)
  allOf :: [a]
  allOf = [ minBound .. maxBound ]
  
invArray :: (Ix.Ix i, Rangeable e, Ix.Ix e) => Array.Array i e -> Array.Array e [i]
invArray l = Array.accumArray (flip (:)) [] rangeOf (map swp $ Array.assocs l)

mods :: Integral a => a -> a -> [a]
mods b n = m:mods b d where
  (d,m) = n `divMod` b

unmod :: Integral a => a -> [a] -> a
unmod _ [] = 0
unmod b (m:l) = m + b*unmod b l

quotRemainder :: (RealFrac a, Integral b) => a -> a -> (b, a)
quotRemainder x y = (a,y*b) where (a,b) = properFraction (x/y)

data Exception = GameError String | GameOver String deriving (Data.Typeable.Typeable, Show)
instance Control.Exception.Exception Exception
gameExn :: Exception -> a
gameExn = Control.Exception.throw
gameError = gameExn . GameError
gameOver = gameExn . GameOver