voronoi_indexed.hs

{-# LANGUAGE TupleSections #-}

module Main where

import Graphics.Gloss
import Graphics.Gloss.Raster.Field
import System.Random
import Data.Semigroup
import GHC.Base (NonEmpty(..))

data Collection = I ! Point                         -- Either, a point
                | T ! Cut ! Collection ! Collection -- Or, a cut and a pair of collections
                deriving (Show)                     -- The cut is represented by an origin, and a target.
                                                    -- Positivity is calculated by dot product.
                                                    -- The first target is arbitrary and will be the first point.
                                                    -- The pair of collections will be negative, then positive

type Cut = (Point, Point) -- Origin, Target

instance Semigroup Collection where
  I p <> T f a b
    | positive p f = T f a (I p <> b)
    | otherwise    = T f (I p <> a) b
  I p     <> I q   = T (mid p q, q) (I p) (I q)
  T _ a b <> y     = a <> (b <> y)

positive :: Point -> Cut -> Bool
positive p (o,t) = dot a b > 0
  where
  a = t .- o
  b = p .- o

(.-) :: Point -> Point -> Point
(a,b) .- (c,d) = (a-c, b-d)

dot :: Point -> Point -> Float
dot (a,b) (c,d) = a*b + c*d

mid :: Point -> Point -> Point
mid (ax,ay) (bx,by) = ((ax+bx) / 2, (ay+by) / 2)

index :: NonEmpty Point -> Collection
index = sconcat . fmap I

sconcat' :: Semigroup a => NonEmpty a -> a
sconcat' (a :| []) = a
sconcat' (a :| [b]) = a <> b
sconcat' (a :| (b:c:ls)) = (a <> b) <> sconcat' (c :| ls)

closest :: Point -> Collection -> Point
closest _ (I p) = p
closest p (T f c1 c2)
  | positive p f = closest p c2
  | otherwise    = closest p c1

pp :: Int -> Collection -> IO ()
pp n (I p) = putStr (replicate n ' ') >> print p
pp n (T f a b) = do
  putStr (replicate n ' ') >> putStr "TL: " >> print (angle f)
  pp (n + 2) a
  putStr (replicate n ' ') >> putStrLn "TR"
  pp (n + 2) b

angle :: RealFloat b => ((b, b), (b, b)) -> b
angle ((center_x, center_y),(touch_x, touch_y)) = theta_radians
  where
  delta_x = touch_x - center_x
  delta_y = touch_y - center_y
  theta_radians = atan2 delta_y delta_x

main :: IO ()
main = do
  g <- randomRs (-1,1) <$> newStdGen
  h <- randomRs (-1,1) <$> newStdGen
  let ps' = zip g h
  let ps  = head ps' :| take 10 (tail ps')
  pp 0 $ index ps
  animateField FullScreen (1,1) (\t p -> mkColor t (closest p (index (mvPoints t ps)))) -- Show Nearest Point
  -- animateField (InWindow "Field" (800,800) (0,0)) (1,1) (\t p -> mkColor t (closest p (index (mvPoints t ps)))) -- Show Nearest Point
  -- animateField (InWindow "Field" (800,800) (0,0)) (1,1) (\t p -> mkColor t $ indexColor p (index (mvPoints t ps))) -- Show Index

mvPoints :: (Functor f, Floating b) => b -> f (b, b) -> f (b, b)
mvPoints t ps = fmap (\(x,y) -> ((sin (t + y) / 20) + x, (sin (2 * t + x) / 20 + y))) ps

indexColor :: Point -> Collection -> Point
indexColor _ (I x)     = x
indexColor p (T f@(o,_) a b)
  | euclid o p < 0.01 = p -- Show cut points
  | positive p f = indexColor p b
  | otherwise = indexColor p a

mkColor :: Float -> Point -> Color
mkColor t (x,y) = rgb (foo x) (foo y) (foo (sin t)) where foo i = succ i / 2

euclid :: Point -> Point -> Float
euclid (a,b) (x,y) = (a-x) ** 2 + (b-y) ** 2