{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}

module Main where

import           Data.List                 (sort)
import qualified Data.StringMap            as M
import qualified Data.StringMap.Dim2Search as D2

-- ----------------------------------------
--
-- auxiliary functions for mapping pairs of Ints to Strings and vice versa

intToKey :: Int -> Int -> Int -> String
intToKey base len val = tok len val ""
    where
      tok 0 _ acc = acc
      tok i v acc = tok (i - 1) v' (d : acc)
          where
            (v', r) = v `divMod` base
            d       = toEnum (r + fromEnum '0')

intPairToKey :: Int -> Int -> (Int, Int) -> String
intPairToKey base len (x, y) = merge x' y'
    where
      x' = intToKey base len x
      y' = intToKey base len y

merge :: [a] -> [a] -> [a]
merge []       []       = []
merge (x : xs) (y : ys) = x : y : merge xs ys

intFromKey :: String -> Int
intFromKey = read

unMerge :: [a] -> ([a], [a])
unMerge [] = ([], [])
unMerge (x : y : s) = (x : xs, y : ys)
    where
      (xs, ys) = unMerge s

-- ----------------------------------------
--
-- experiment to understand 2-dimensional location
-- search implemented by using the StringMap impl.
--
-- an ordering on strings (representing pairs of ints)
-- that is isomorphic to the partial ordering
-- used for 2-dimensional search

instance Ord Point' where
    (P' s1) <= (P' s2) = s1 `le` s2
        where
          le [] [] = True
          le (x1 : y1 : ds1) (x2 : y2 : ds2)
              | x1 == x2 && y1 == y2 = ds1 `le`  ds2
              | x1 == x2 && y1 <  y2 = ds1 `leX` ds2
              | x1 <  x2 && y1 == y2 = ds1 `leY` ds2
              | x1 <  x2 && y1 <  y2 = True
              | otherwise            = False

          leX [] [] = True                      -- the result for the Y dimension is already known
          leX (x1 : y1 : ds1) (x2 : y2 : ds2)
              | x1 == x2  = ds1 `leX` ds2
              | x1 <  x2  = True
              | otherwise = False

          leY [] [] = True                      -- the result for the X dimension is already known
          leY (x1 : y1 : ds1) (x2 : y2 : ds2)
              | y1 == y2  = ds1 `leY` ds2
              | y1 <  y2  = True
              | otherwise = False

-- toPoint' and fromPoint': the bijection Point <-> Point'

toPoint' :: Point -> Point'
toPoint' (P p) = P' $ intPairToKey base len p
    where
      base =  2         -- or 10
      len  =  10        -- or  3  (or something else)

fromPoint' :: Point' -> Point
fromPoint' (P' ds) = P (intFromKey xs, intFromKey ys)
    where
      (xs, ys) = unMerge ds

-- the test, whether the `le` ordering is preserved, when working with Point'
propOrdered :: Point -> Point -> Bool
propOrdered p1 p2
    = (p1 `le` p2) == (toPoint' p1 <= toPoint' p2)

-- very quick check test
propTest :: Int -> [(Point, Point)]
propTest n
    = filter (not . uncurry propOrdered) qs
      where
        xs = [1..n]
        ps = [P (x, y) | x <- xs, y <- xs]
        qs = [(p1, p2) | p1 <- ps, p2 <- ps]

test1 :: Bool
test1 = null $ propTest 20

-- ----------------------------------------

newtype Point     = P   {unP :: (Int, Int)    } deriving (Eq)
newtype PointSet  = PS  {unPS :: [Point]       } deriving (Eq)
                                                -- assuming only smart constructor mkPS is used

newtype Point'    = P'  {unP' :: String        } deriving (Eq)
newtype PointSet' = PS' {unPS' :: M.StringMap ()} deriving (Eq)

instance Show Point     where show = show . unP
instance Show Point'    where show = show . unP'
instance Show PointSet  where show = show . unPS
instance Show PointSet' where show = show . M.keys . unPS'

class PartOrd a where
    le :: a -> a -> Bool
    ge :: a -> a -> Bool

instance PartOrd Point where
    (P (x1, y1)) `le` (P (x2, y2))
        = x1 <= x2 && y1 <= y2

    (P (x1, y1)) `ge` (P (x2, y2))
        = x1 >= x2 && y1 >= y2

instance PartOrd Point' where
    (P' p1) `le` (P' p2)
        = not . M.null . D2.lookupLE p2 $ (M.singleton p1 ())

    (P' p1) `ge` (P' p2)
        = not . M.null . D2.lookupGE p2 $ (M.singleton p1 ())

class Lookup p s | s -> p where
    lookupLE :: p -> s -> s
    lookupGE :: p -> s -> s

instance Lookup Point PointSet where
    lookupLE p ps = PS . filter (`le` p) . unPS $ ps
    lookupGE p ps = PS . filter (`ge` p) . unPS $ ps

instance Lookup Point' PointSet' where
    lookupLE p ps = PS' . D2.lookupLE (unP' p) . unPS' $ ps
    lookupGE p ps = PS' . D2.lookupGE (unP' p) . unPS' $ ps

-- the bijection between Point and Point'

pToP' :: Point -> Point'
pToP' = P' . intPairToKey 10 5 . unP    -- base 10, 5 digits

p'ToP :: Point' -> Point
p'ToP (P' p') = P (intFromKey xs, intFromKey ys)
    where
      (xs, ys) = unMerge p'

-- the bijection between PointSet and PointSet'

psToPS' :: PointSet -> PointSet'
psToPS' = PS' . M.fromList . map (\(P' x) -> (x, ())) . map pToP' . unPS

ps'ToPS :: PointSet' -> PointSet
ps'ToPS = mkPS . map (unP . p'ToP . P') . M.keys . unPS'

mkP :: Int -> Int -> Point
mkP x y = P (x, y)

mkP' :: Int -> Int -> Point'
mkP' x y = pToP' $ mkP x y

mkPS :: [(Int, Int)] -> PointSet
mkPS = PS . map P . sort

mkPS' :: [(Int, Int)] -> PointSet'
mkPS' = psToPS' . mkPS

mkxx :: Int -> Point
mkxx i = mkP i i

mkxx' :: Int -> Point'
mkxx' = pToP' . mkxx

mkD2 :: [Int] -> PointSet
mkD2 = PS . map mkxx

mkD2' :: [Int] -> PointSet'
mkD2' = psToPS' . mkD2

d1 :: PointSet
d1 = mkD2 [1,10,100,105,107,125,200, 205, 222]

d1' :: PointSet'
d1' = psToPS' d1

d2 :: PointSet
d2 = mkD2 [2,10,20,25,100,111,155,200,333,500]

d2' :: PointSet'
d2' = psToPS' d2

d0' :: PointSet'
d0' = mkD2' [10,100]


mkSquare :: Int -> Int -> PointSet
mkSquare n m = mkPS [(i, j) | i <- [n..m], j <- [n..m]]

-- input list must contain at least 3 different elements
mkPointPointSet :: [Int] -> ([Point], PointSet)
mkPointPointSet xs0
    = (ps, ps')
      where
        xs@(_ : ys@(_:_:_)) = sort xs0
        xs'                  = init ys
        ps  =      [mkP i j | i <- xs,  j <- xs ]
        ps' = mkPS [ (i, j) | i <- xs', j <- xs']


ps1 :: PointSet
xs1 :: [Point]
(xs1, ps1) =  mkPointPointSet [1,2,10,20,25,100,111,155,200,333,500,505]

lawBijection :: PointSet -> Bool
lawBijection ps
    = ps == (ps'ToPS . psToPS' $ ps)

lawPredicateMorphism :: (Point -> Bool) -> (Point' -> Bool) ->
                        Point -> Bool
lawPredicateMorphism p p' x
    = p x == (p' $ pToP' x)

lawPredicate2Morphism :: (Point -> Point -> Bool) -> (Point' -> Point' -> Bool) ->
                         Point -> Point -> Bool
lawPredicate2Morphism p2 p2' x y
    = lawPredicateMorphism (p2 x) (p2' $ pToP' x) y

lawPointSetMorphism :: (PointSet -> PointSet) -> (PointSet' -> PointSet') ->
                       PointSet -> Bool
lawPointSetMorphism f f' ps
    = f ps == (ps'ToPS . f' . psToPS' $ ps)

lawLookupGE :: Point -> PointSet -> Bool
lawLookupGE p ps = lawPointSetMorphism (lookupGE p) (lookupGE $ pToP' p) ps

lawLookupLE :: Point -> PointSet -> Bool
lawLookupLE p ps = lawPointSetMorphism (lookupLE p) (lookupLE $ pToP' p) ps

testPointPointSet :: (Point -> PointSet -> Bool) -> ([Point], PointSet) -> [Point]
testPointPointSet law (xs, ps)
    = filter (\p -> not $ law p ps) xs

testLookup :: ([Point], PointSet) -> Bool
testLookup ps
    = null (testPointPointSet lawLookupLE ps)
      &&
      null (testPointPointSet lawLookupGE ps)

theTest :: Bool
theTest = testLookup $
       mkPointPointSet [1,2,10,20,25,100,111,155,200,333,500,505]

main :: IO ()
main = print theTest >> return ()

-- ----------------------------------------