Hex.lhs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 \begin{document}
  12
  13 An abstract hex board type.
  14
  15 We coordinatize by the integral points of the hyperplane x+y+z=0:
  16
  17 Some hopefully elucidatory diagrams:
  18
  19    .   .
  20    v.        u = (1,0,-1)
  21  .   .___.   v = (-1,1,0)
  22    w,  u     w = (0,-1,1)
  23    .   .
  24                                    X
  25                              -2-1 0
  26        Y                     , , , 1
  27      . | .               2 -. . * , 2
  28        |                1 -. . * * ,     * : "principal hextant"
  29    .   .   .         Y 0 -. . 0 . .           x>=0&&y>0
  30      /   \             -1 -. . . . `
  31    / .   . \            -2 -. . . `-2
  32   Z          X               ` ` `-1
  33                               2 1 0
  34                                  Z
  35
  36
  37 \begin{code}
  38 {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
  39 module Hex where
  40
  41 import Data.Ix
  42 import Data.Semigroup as Sem
  43 import Data.Monoid
  44 import Data.Ratio
  45 import Data.List (minimumBy)
  46 import Data.Function (on)
  47
  48 data HexVec = HexVec {hx,hy,hz :: Int} deriving (Eq, Ord, Show, Read)
  49
  50 hu,hv,hw :: HexVec
  51 hu = HexVec    1    0 (-1)
  52 hv = HexVec (-1)    1    0
  53 hw = HexVec    0 (-1)    1
  54
  55 hv2tup :: HexVec -> (Int,Int,Int)
  56 hv2tup (HexVec x y z) = (x,y,z)
  57
  58 tup2hv :: (Int,Int,Int) -> HexVec
  59 tup2hv (x,y,z)
  60     | x+y+z == 0 = HexVec x y z
  61     | otherwise = error "bad hex"
  62
  63 hv2tupxy :: HexVec -> (Int,Int)
  64 hv2tupxy (HexVec x y _) = (x,y)
  65
  66 tupxy2hv :: (Int,Int) -> HexVec
  67 tupxy2hv (x,y) = HexVec x y (-(x+y))
  68
  69 hexLen :: HexVec -> Int
  70 hexLen (HexVec x y z) = maximum $ abs <$> [x,y,z]
  71
  72 hexDot :: HexVec -> HexVec -> Int
  73 hexDot (HexVec x y z) (HexVec x' y' z') = x*x'+y*y'+z*z'
  74
  75 hexDisc :: Int -> [HexVec]
  76 hexDisc r = [ HexVec x y z | x <- [-r..r], y <- [-r..r],
  77         let z = -x-y, abs z <= r ]
  78
  79 hextant :: HexVec -> Int
  80 -- ^undefined at zero
  81 --        ` 1 '
  82 --        2` '0
  83 --        --*--
  84 --        3' `5
  85 --        ' 4 `
  86 hextant (HexVec x y z)
  87     | x > 0 && y >= 0 = 0
  88     | -z > 0 && -x >= 0 = 1
  89     | y > 0 && z >= 0 = 2
  90     | -x > 0 && -y >= 0 = 3
  91     | z > 0 && x >= 0 = 4
  92     | -y > 0 && -z >= 0 = 5
  93     | otherwise = error "Tried to take hextant of zero"
  94
  95 -- hextant (rotate n hu) == n
  96 rotate :: Int -> HexVec -> HexVec
  97 rotate 0 v = v
  98 rotate 2 (HexVec x y z) = HexVec z x y
  99 rotate (-2) (HexVec x y z) = HexVec y z x
 100 rotate 1 v = neg $ rotate (-2) v
 101 rotate (-1) v = neg $ rotate 2 v
 102 rotate n v | n < 0 = rotate (n+6) v
 103         | n > 6 = rotate (n-6) v
 104         | otherwise = rotate (n-2) (rotate 2 v)
 105
 106 cmpAngles :: HexVec -> HexVec -> Ordering
 107 -- ^ordered by angle, taking cut along u
 108 cmpAngles v@(HexVec x y _) v'@(HexVec x' y' _)
 109     | v == zero && v' == zero = EQ
 110     | v == zero = LT
 111     | hextant v /= hextant v' =
 112         compare (hextant v) (hextant v')
 113     | hextant v /= 0 =
 114         cmpAngles (rotate (-(hextant v)) v) (rotate (-(hextant v)) v')
 115     | otherwise = compare (y%x) (y'%x')
 116
 117 instance Ix HexVec where
 118     range (h,h') =
 119         [ tupxy2hv (x,y) | (x,y) <- range (hv2tupxy h, hv2tupxy h') ]
 120     inRange (h,h') h'' =
 121         inRange (hv2tupxy h, hv2tupxy h') (hv2tupxy h'')
 122     index (h,h') h'' =
 123         index (hv2tupxy h , hv2tupxy h') (hv2tupxy h'')
 124
 125 -- HexDirs are intended to be HexVecs of length <= 1
 126 type HexDir = HexVec
 127 isHexDir :: HexVec -> Bool
 128 isHexDir v = hexLen v == 1
 129
 130 type HexDirOrZero = HexVec
 131 isHexDirOrZero :: HexVec -> Bool
 132 isHexDirOrZero v = hexLen v <= 1
 133
 134 hexDirs :: [HexDir]
 135 hexDirs = (`rotate` hu) <$> [0..5]
 136
 137 hexVec2HexDirOrZero :: HexVec -> HexDirOrZero
 138 hexVec2HexDirOrZero v
 139     | v == zero = zero
 140     | otherwise = rotate (hextant v) hu
 141
 142 --minusHu = HexVec    (-1) 1    0
 143 --minusHv = HexVec    0    (-1) 1
 144 --minusHw = HexVec    1    0    (-1)
 145
 146 canonDir :: HexDir -> HexDir
 147 canonDir dir | dir `elem` [ hu, hv, hw ] = dir
 148              | isHexDir dir = canonDir $ neg dir
 149              | dir == zero = zero
 150              | otherwise = undefined
 151
 152 scaleToLength :: Int -> HexVec -> HexVec
 153 scaleToLength n v@(HexVec x y z) =
 154     let
 155         l = hexLen v
 156         lv' = (`div`l) . (n*) <$> [x,y,z]
 157         minI = fst $ minimumBy (compare `on` snd) $
 158             zip [0..] $ abs <$> lv'
 159         [x'',y'',z''] = zipWith (-) lv' [ d
 160                 | i <- [0..2]
 161                 , let d = if i == minI then sum lv' else 0 ]
 162     in HexVec x'' y'' z''
 163 truncateToLength :: Int -> HexVec -> HexVec
 164 truncateToLength n v = if hexLen v <= n then v else scaleToLength n v
 165 \end{code}
 166
 167 Some general stuff on groups and actions and principal homogeneous spaces. We
 168 use additive notation, even though there's no assumption of commutativity.
 169
 170 \begin{code}
 171 class Monoid g => Grp g where
 172     neg :: g -> g
 173     zero :: g
 174     zero = mempty
 175
 176 instance (Grp g1, Grp g2) => Grp (g1,g2) where
 177     neg (a,b) = (neg a, neg b)
 178
 179 infixl 6 +^
 180 infixl 6 -^
 181 class Action a b where
 182     (+^) :: a -> b -> b
 183 instance Monoid m => Action m m where
 184     (+^) = mappend
 185
 186 class Differable a b c where
 187     (-^) :: a -> b -> c
 188 instance Grp g => Differable g g g where
 189     x -^ y = x +^ neg y
 190
 191 newtype PHS g = PHS { getPHS :: g }
 192     deriving (Eq, Ord, Show, Read)
 193
 194 instance Grp g => Action g (PHS g) where
 195     x +^ (PHS y) = PHS (x +^ y)
 196 instance Grp g => Differable (PHS g) (PHS g) g where
 197     (PHS x) -^ (PHS y) = x -^ y
 198
 199 infixl 7 *^
 200 class MultAction a b where
 201     (*^) :: a -> b -> b
 202
 203 instance (Grp a, Integral n) => MultAction n a where
 204     0 *^ _              = zero
 205     1 *^ x              = x
 206     n *^ x
 207         | n < 0     = (-n) *^ neg x
 208         | even n    = (n `div` 2) *^ (x +^ x)
 209         | otherwise = x +^ ((n `div` 2) *^ (x +^ x))
 210
 211 \end{code}
 212
 213 Now we define HexSpaces as spaces acted on by HexVec, and with a canonical
 214 HexVec difference between two points (e.g. PHS HexVec).
 215
 216 \begin{code}
 217
 218 instance Sem.Semigroup HexVec where
 219     (HexVec x y z) <> (HexVec x' y' z') = HexVec (x+x') (y+y') (z+z')
 220 instance Monoid HexVec where
 221     mempty = HexVec 0 0 0
 222     mappend = (Sem.<>)
 223 instance Grp HexVec where
 224     neg (HexVec x y z) = HexVec (-x) (-y) (-z)
 225
 226 class (Action HexVec b, Differable b b HexVec) => HexSpace b
 227 instance HexSpace (PHS HexVec)
 228
 229 type HexPos = PHS HexVec
 230 origin :: HexPos
 231 origin = PHS zero
 232
 233 \end{code}
 234
 235 Testing:
 236
 237 \begin{code}
 238 {-
 239 r = range (tup2hv (-3,-3,6), tup2hv (3,3,-6))
 240 test1 = index (tup2hv (-3,-3,6), tup2hv (3,3,-6)) (r!!5) == 5
 241
 242 a :: PHS HexVec
 243 a = PHS zero
 244 test2 = hu +^ a
 245 -}
 246 \end{code}
 247 \end{document}