-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

\begin{document}

An abstract hex board type.

We coordinatize by the integral points of the hyperplane x+y+z=0:

Some hopefully elucidatory diagrams:

   .   .
   v.        u = (1,0,-1)
 .   .___.   v = (-1,1,0)
   w,  u     w = (0,-1,1)
   .   .
                                   X
                             -2-1 0
       Y                     , , , 1
     . | .               2 -. . * , 2
       |                1 -. . * * ,     * : "principal hextant"
   .   .   .         Y 0 -. . 0 . .           x>=0&&y>0
     /   \             -1 -. . . . `
   / .   . \            -2 -. . . `-2
  Z          X               ` ` `-1
                              2 1 0
                                 Z


\begin{code}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
module Hex where

import Data.Ix
import Data.Semigroup as Sem
import Data.Monoid
import Data.Ratio
import Data.List (minimumBy)
import Data.Function (on)
   
data HexVec = HexVec {hx,hy,hz :: Int} deriving (Eq, Ord, Show, Read)

hu,hv,hw :: HexVec
hu = HexVec    1    0 (-1)
hv = HexVec (-1)    1    0
hw = HexVec    0 (-1)    1

hv2tup :: HexVec -> (Int,Int,Int)
hv2tup (HexVec x y z) = (x,y,z)

tup2hv :: (Int,Int,Int) -> HexVec
tup2hv (x,y,z) 
    | x+y+z == 0 = HexVec x y z
    | otherwise = error "bad hex"

hv2tupxy :: HexVec -> (Int,Int)
hv2tupxy (HexVec x y _) = (x,y)

tupxy2hv :: (Int,Int) -> HexVec
tupxy2hv (x,y) = HexVec x y (-(x+y))

hexLen :: HexVec -> Int
hexLen (HexVec x y z) = maximum $ abs <$> [x,y,z]

hexDot :: HexVec -> HexVec -> Int
hexDot (HexVec x y z) (HexVec x' y' z') = x*x'+y*y'+z*z'

hexDisc :: Int -> [HexVec] 
hexDisc r = [ HexVec x y z | x <- [-r..r], y <- [-r..r],
        let z = -x-y, abs z <= r ]

hextant :: HexVec -> Int
-- ^undefined at zero
--        ` 1 '
--        2` '0
--        --*--
--        3' `5
--        ' 4 `
hextant (HexVec x y z)
    | x > 0 && y >= 0 = 0
    | -z > 0 && -x >= 0 = 1
    | y > 0 && z >= 0 = 2
    | -x > 0 && -y >= 0 = 3
    | z > 0 && x >= 0 = 4
    | -y > 0 && -z >= 0 = 5
    | otherwise = error "Tried to take hextant of zero"

-- hextant (rotate n hu) == n
rotate :: Int -> HexVec -> HexVec
rotate 0 v = v
rotate 2 (HexVec x y z) = HexVec z x y
rotate (-2) (HexVec x y z) = HexVec y z x
rotate 1 v = neg $ rotate (-2) v
rotate (-1) v = neg $ rotate 2 v
rotate n v | n < 0 = rotate (n+6) v
        | n > 6 = rotate (n-6) v
        | otherwise = rotate (n-2) (rotate 2 v)

cmpAngles :: HexVec -> HexVec -> Ordering
-- ^ordered by angle, taking cut along u
cmpAngles v@(HexVec x y _) v'@(HexVec x' y' _)
    | v == zero && v' == zero = EQ
    | v == zero = LT
    | hextant v /= hextant v' =
        compare (hextant v) (hextant v')
    | hextant v /= 0 =
        cmpAngles (rotate (-(hextant v)) v) (rotate (-(hextant v)) v')
    | otherwise = compare (y%x) (y'%x')

instance Ix HexVec where
    range (h,h') = 
        [ tupxy2hv (x,y) | (x,y) <- range (hv2tupxy h, hv2tupxy h') ]
    inRange (h,h') h'' =
        inRange (hv2tupxy h, hv2tupxy h') (hv2tupxy h'')
    index (h,h') h'' =
        index (hv2tupxy h , hv2tupxy h') (hv2tupxy h'')

-- HexDirs are intended to be HexVecs of length <= 1
type HexDir = HexVec
isHexDir :: HexVec -> Bool
isHexDir v = hexLen v == 1

type HexDirOrZero = HexVec
isHexDirOrZero :: HexVec -> Bool
isHexDirOrZero v = hexLen v <= 1

hexDirs :: [HexDir]
hexDirs = (`rotate` hu) <$> [0..5]

hexVec2HexDirOrZero :: HexVec -> HexDirOrZero
hexVec2HexDirOrZero v
    | v == zero = zero
    | otherwise = rotate (hextant v) hu

--minusHu = HexVec    (-1) 1    0
--minusHv = HexVec    0    (-1) 1
--minusHw = HexVec    1    0    (-1)

canonDir :: HexDir -> HexDir
canonDir dir | dir `elem` [ hu, hv, hw ] = dir
             | isHexDir dir = canonDir $ neg dir
             | dir == zero = zero
             | otherwise = undefined

scaleToLength :: Int -> HexVec -> HexVec
scaleToLength n v@(HexVec x y z) =
    let
        l = hexLen v
        lv' = (`div`l) . (n*) <$> [x,y,z]
        minI = fst $ minimumBy (compare `on` snd) $
            zip [0..] $ abs <$> lv'
        [x'',y'',z''] = zipWith (-) lv' [ d
                | i <- [0..2]
                , let d = if i == minI then sum lv' else 0 ]
    in HexVec x'' y'' z''
truncateToLength :: Int -> HexVec -> HexVec
truncateToLength n v = if hexLen v <= n then v else scaleToLength n v
\end{code}
     
Some general stuff on groups and actions and principal homogeneous spaces. We
use additive notation, even though there's no assumption of commutativity.

\begin{code}
class Monoid g => Grp g where
    neg :: g -> g
    zero :: g
    zero = mempty

instance (Grp g1, Grp g2) => Grp (g1,g2) where
    neg (a,b) = (neg a, neg b)

infixl 6 +^
infixl 6 -^
class Action a b where
    (+^) :: a -> b -> b
instance Monoid m => Action m m where
    (+^) = mappend

class Differable a b c where
    (-^) :: a -> b -> c
instance Grp g => Differable g g g where
    x -^ y = x +^ neg y

newtype PHS g = PHS { getPHS :: g }
    deriving (Eq, Ord, Show, Read)

instance Grp g => Action g (PHS g) where
    x +^ (PHS y) = PHS (x +^ y)
instance Grp g => Differable (PHS g) (PHS g) g where
    (PHS x) -^ (PHS y) = x -^ y
    
infixl 7 *^
class MultAction a b where
    (*^) :: a -> b -> b
    
instance (Grp a, Integral n) => MultAction n a where
    0 *^ _              = zero
    1 *^ x              = x
    n *^ x
        | n < 0     = (-n) *^ neg x
        | even n    = (n `div` 2) *^ (x +^ x)
        | otherwise = x +^ ((n `div` 2) *^ (x +^ x))

\end{code}

Now we define HexSpaces as spaces acted on by HexVec, and with a canonical
HexVec difference between two points (e.g. PHS HexVec).

\begin{code}

instance Sem.Semigroup HexVec where
    (HexVec x y z) <> (HexVec x' y' z') = HexVec (x+x') (y+y') (z+z')
instance Monoid HexVec where
    mempty = HexVec 0 0 0
    mappend = (Sem.<>)
instance Grp HexVec where
    neg (HexVec x y z) = HexVec (-x) (-y) (-z)

class (Action HexVec b, Differable b b HexVec) => HexSpace b
instance HexSpace (PHS HexVec)

type HexPos = PHS HexVec
origin :: HexPos
origin = PHS zero

\end{code}

Testing:

\begin{code}
{-
r = range (tup2hv (-3,-3,6), tup2hv (3,3,-6))
test1 = index (tup2hv (-3,-3,6), tup2hv (3,3,-6)) (r!!5) == 5

a :: PHS HexVec
a = PHS zero
test2 = hu +^ a
-}
\end{code}
\end{document}