module Surface where

import Prelude
import List
import Maybe

type ZeroHandle = [Int]  -- must be at least length 3
type Edge       = (Int,Int)
type OneHandle  = (Edge,Edge)
type Surface    = ([ZeroHandle], [OneHandle])

-------------------------------------------------------------
-- surface invariants

euler :: Surface -> Int
euler surface = length (fst surface) - length (snd surface)

eulerClosedSurface :: Surface -> Int
eulerClosedSurface closedSurface
  = ( euler closedSurface ) + (length (boundary closedSurface) )

numComponents :: Surface -> Int
numComponents = length . components

isConnected :: Surface -> Bool
isConnected surface = numComponents surface <= 1

isOrientable :: Surface -> Bool
isOrientable surface 
  = all isOrientableConnectedSurface (components surface)
  where
  isOrientableConnectedSurface connectedSurface 
    = (length (components (orientationCover connectedSurface)) ) == 2

genus :: Surface -> Int
genus surface = sum ( map genusOfConnectedSurface ( components surface ) )
  where
  genusOfConnectedSurface surface
    | isOrientable surface = 1 - ( (eulerClosedSurface surface) `div` 2 )
    | otherwise            = 2 - (eulerClosedSurface surface)

-------------------------------------------------------------
-- utilities

removeSameEdges :: [Edge] -> [Edge] -> [Edge]
removeSameEdges xs ys = foldr removeSame ys xs
  where
  removeSame x ys = [ y | y <- ys, not (isSameEdge x y) ]

isSameEdge :: Edge -> Edge -> Bool
isSameEdge (a,b) (c,d) = (a,b) == (c,d) || (a,b) == (d,c)

allZeroHandleVertices :: Surface -> [Int]
allZeroHandleVertices surface =  concat ( fst surface )

allZeroHandleEdges :: Surface -> [Edge]
allZeroHandleEdges surface = concatMap zeroHandleEdges (fst surface)
  where
  zeroHandleEdges zero = zip zero ((tail zero) ++ [head zero])

allOneHandleEnds :: Surface -> [Edge]
allOneHandleEnds surface = concatMap ends (snd surface)
  where
  ends ((a,b),(c,d)) = [(a,b),(c,d)]

allOneHandleSides :: Surface -> [Edge]
allOneHandleSides surface = concatMap sides (snd surface)
  where
  sides ((a,b),(c,d)) = [(a,c),(b,d)]

-------------------------------------------------------------
-- checking that the surface is well-defined

isTrueSurface :: Surface -> IO()
isTrueSurface surface
  | ( not . null ) [ zero | zero <- fst surface, length zero < 3 ]
    = putStr "Not true surface (has 0-handle with fewer than three vertices)."
  | hasDuplicates ( allZeroHandleVertices surface ) 
    = putStr "Not true surface (has duplicate 0-handle vertices)."
  | hasDuplicates (addReverseEdges (allOneHandleEnds surface))
    = putStr "Not true surface (has multiple 1-handle attachings to one edge)."
  | ( not . null ) ( removeSameEdges 
    (allZeroHandleEdges surface) (allOneHandleEnds surface) )
    = putStr "Not true surface (has 1-handle attached to nonexistent edge)."
  | otherwise = putStr "True surface."

hasDuplicates :: Eq a => [a] -> Bool
hasDuplicates [ ] = False
hasDuplicates (x:xs) = (elem x xs) || hasDuplicates xs

addReverseEdges :: [Edge] -> [Edge]
addReverseEdges = concatMap (\(a,b) -> [(a,b),(b,a)])

-------------------------------------------------------------
-- finding the boundary

continuation :: Edge -> [Edge] -> Maybe Edge
continuation _ [ ] = Nothing
continuation (a,b) ((c,d):es)
  | b == c    = Just (c,d)
  | b == d    = Just (d,c)
  | otherwise = continuation (a,b) es

circuit :: Edge -> [Edge] -> [Edge]
circuit edge edges
  | isNothing next = [edge]
  | otherwise = edge : 
    (circuit (fromJust next) (removeSameEdges [fromJust next] edges))
  where
  next = continuation edge edges

findCircuits :: [Edge] -> [[Edge]]
findCircuits [ ] = [ ]
findCircuits (edge:edges) = (circuit edge edges) : 
  (findCircuits (removeSameEdges (circuit edge edges) edges))

freeEdges :: Surface -> [Edge]
freeEdges surface  = allOneHandleSides surface ++
  (removeSameEdges (allOneHandleEnds surface) (allZeroHandleEdges surface))

boundary :: Surface -> [[Edge]]
boundary = findCircuits . freeEdges

-------------------------------------------------------------
-- finding components

incident :: OneHandle -> ZeroHandle -> Bool
-- at last one end of the 1-handle is in the 0-handle
incident ((a,b),(c,d)) zeroHandle 
  = a `elem` zeroHandle || c `elem` zeroHandle

joinsZeroHandles :: ZeroHandle -> ZeroHandle -> OneHandle -> Bool
joinsZeroHandles zero1 zero2 one 
  = (incident one zero1) && (incident one zero2)

isNeighbor :: Surface -> ZeroHandle -> ZeroHandle -> Bool
isNeighbor surface zero1 zero2 
  = any (joinsZeroHandles zero1 zero2) (snd surface)

zeroNeighbors :: Surface -> [ZeroHandle] -> [ZeroHandle]
zeroNeighbors surface zeros 
  = nub (concat [ zeroNeighbors' surface handle | handle <- zeros ])

zeroNeighbors' :: Surface -> ZeroHandle -> [ZeroHandle]
zeroNeighbors' surface zero 
  = [ handle | handle <- (fst surface), 
    handle == zero || isNeighbor surface zero handle ]

zeroComponent :: Surface -> [ZeroHandle] -> [ZeroHandle]
zeroComponent surface zeros
  | zeroNeighbors surface zeros == zeros = zeros
  | otherwise = zeroComponent surface (zeroNeighbors surface zeros)

connectedComponent :: Surface -> ZeroHandle -> Surface
connectedComponent surface zero = (zeros,ones)
  where
  zeros = zeroComponent surface [zero]
  ones = nub [ handle | handle <- snd surface, zero <- zeros, incident handle zero ]

components :: Surface -> [Surface]
components surface = component' surface (fst surface)
  where
  component' s [] = []
  component' s (z:zs) = (connectedComponent s z) :
    ( component' s ( zs \\ (fst (connectedComponent s z)) ) )

-------------------------------------------------------------
-- orientation double cover

maxVertexDifference :: Surface -> Int
maxVertexDifference surface = (last vertices) - (head vertices)
  where
  vertices = sort ( allZeroHandleVertices surface )

isOrientationPreserving :: OneHandle -> Surface -> Bool
isOrientationPreserving ((a,b),(c,d)) surface
  | firstEdgePlus && not secondEdgePlus = True
  | not firstEdgePlus && secondEdgePlus = True
  | otherwise                           = False
  where
  firstEdgePlus  = any ( == (a,b)) (allZeroHandleEdges surface)
  secondEdgePlus = any ( == (c,d)) (allZeroHandleEdges surface)

coverHandles :: Surface -> OneHandle -> [OneHandle]
coverHandles surface ((a,b),(c,d))
  | isOrientationPreserving ((a,b),(c,d)) surface
    = [((a,b),(c,d)),((a + diff,b + diff),(c + diff,d + diff))]
  | otherwise = [((a,b),(c + diff,d + diff)),((a + diff,b + diff),(c,d))]
  where
  diff = 1 +  maxVertexDifference surface

orientationCover :: Surface -> Surface
orientationCover surface = (zeroHandles, oneHandles)
  where
  zeroHandles = (fst surface) ++ newZeroHandles 
  newZeroHandles = [ map (\x -> x + diff) zero | zero <- (fst surface) ]
  oneHandles = concatMap (coverHandles surface) (snd surface)
  diff = 1 + maxVertexDifference surface

-------------------------------------------------------------
-- standard surfaces

disk, annulus, torus, mobius, klein :: Surface
disk = ([[1,2,3]],[])
annulus = obSurface 0 2
torus = obSurface 1 1
mobius = nbSurface 1 1
klein = nbSurface 2 1

obSurface :: Int -> Int -> Surface
-- orientable surface of genus g with k boundary circles
obSurface g k
  | g < 0 = error "obSurface: genus must be at least 0"
  | k < 1 = error "obSurface: number of boundary circles must be at least 1"
  | g == 0 && k == 1 = disk
  | otherwise = (zeros, ones)
    where
    zeros = [[1..4*g+2*(k-1)+1]]
    ones  = (concatMap oHandle [1,5..4*g-3]) ++ 
            (concatMap bCircle [4*g+1,4*g+3..4*g+2*k-3])

oSurface :: Int -> Surface
-- orientable surface of genus g with 1 boundary circle
oSurface g = obSurface g 1

nbSurface :: Int -> Int -> Surface
-- nonorientable surface of genus g with k boundary circles
nbSurface g k
  | g < 1 = error "nbSurface: genus must be at least 1"
  | k < 1 = error "nbSurface: number of boundary circles must be at least 1"
  | otherwise = (zeros, ones)
    where
    zeros = [[1..2*g+2*k-1]]
    ones  = (concatMap nHandle [1,3..2*g-1]) ++ 
            (concatMap bCircle [2*g+1,2*g+3..2*g+2*k-3])

nSurface :: Int -> Surface
-- nonorientable surface of genus g with 1 boundary circle
nSurface g = nbSurface g 1

-- auxiliary functions for construction of standard surfaces

oHandle :: Int -> [OneHandle]
oHandle n = [((n,n+1),(n+3,n+2)),((n+1,n+2),(n+4,n+3))]

nHandle :: Int -> [OneHandle]
nHandle n = [((n,n+1),(n+1,n+2))]

bCircle :: Int -> [OneHandle]
bCircle n = [((n,n+1),(n+2,n+1))]

-------------------------------------------------------------
-- other test surfaces

d1,d2 :: ZeroHandle
d1 = [1,2,3,4]
d2 = [5, 6, 7, 8, 9, 10]

h1,h2,h3,h4,h5 :: OneHandle 
h1 = ((4,1),(5,10))
h2 = ((10, 9),(9, 8))
h3 = ((3,4), (5,6))
h4 = ((2,1), (8,7))
h5 = ((2,3), (7,6))

s :: Surface
s = ([d1,d2],[h1, h2, h3, h4, h5])

empty :: Surface
empty = ([],[])

twoAnnuli :: Surface
twoAnnuli = ( [[1,2,3],[4,5,6]], [((1,2),(1,3)),((4,5),(4,6))] )

sparse :: Surface
sparse = ([[1,2,3,4,5,6,7,8],[67,14,10,-7,22,0,-34]],
  [((6,7),(-7,22)),((0,22),(3,4)),((14,67),(8,1))])

trivialHandle :: Surface
trivialHandle = ([[1,2,3],[4,5,6]], [((1,2),(4,5))])

longAnnulus :: Surface
longAnnulus = ([ [1,2,3], [4,5,6], [7,8,9], [10,11,12], [13,14,15], [16,17,18] ],
  [ ((1,3),(6,4)), ((5,4),(7,8)), ((7,9),(12,10)), ((11,10),(13,14)),
  ((13,15),(18,16)), ((17,16),(1,2)) ] )

genus2 :: Surface
genus2 = ( [ [1,2,3,4,5,6,7,8] ],
    [ ((1,8),(2,3)), ((2,1),(3,4)), ((5,4),(6,7)), ((6,5),(7,8)) ] )

genus3 :: Surface 
genus3 = ( [[1,2,3,4,5,6,7,8,9,10,11,12]],
    [ ((1,12),(6,7)), ((1,2),(8,7)), ((2,3),(9,8)),
      ((3,4),(10,9)), ((4,5),(11,10)), ((5,6),(12,11)) ] )

oppositeSides :: Int -> Surface
-- the surface obtained by identifying opposite sides of a 2n-sided polygon
oppositeSides n
  | n < 2     = error "polygon: n must be at least 2"
  | otherwise = (zeros, ones)
  where
  zeros = [[1..2*n]]
  ones = (map (\x -> ((x,x+1),(x+n+1,x+n))) [1..n-1]) ++ [((2*n,1),(n+1,n))]

-------------------------------------------------------------
-- fake surfaces

badSurface1 :: Surface
badSurface1 = ([[1,2]], [((1,2),(2,1)),((1,2),(1,2))])

badSurface2 :: Surface
badSurface2 = ([[1,2,3],[3,4,5]], [((1,2),(2,1))])

badSurface3 :: Surface
badSurface3 = ([[1,2,3]], [((1,2),(2,3)),((3,4),(4,5))])

badSurface4 :: Surface
badSurface4 = ([[1,2,3]], [((1,2),(2,1)),((1,2),(1,2))])

badSurface5 :: Surface
badSurface5 = ([[1,2,3]], [((1,2),(2,1)),((1,3),(1,3))])

badSurface6 :: Surface
badSurface6 = ( [ [1,2,11],[3,4,12],[5,6,13],[7,8,14],[9,10,15] ],
  [ ((2,1),(4,3)),((4,3),(6,5)),((6,5),(8,7)),((8,7),(10,9)),((10,9),(2,1)) ] )