sordina/hilbert-index-random-points.hs

## hilbert-index-random-points.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}

import Data.Maybe (fromMaybe, catMaybes)
import Data.List (tails, sortBy)
import Data.Ord (comparing)
import Data.List.Split
import Text.Printf
import Text.InterpolatedString.Perl6
import Control.Arrow ((***))
import System.Random
import qualified Data.Map as M

type HilbertCoord = (Integer, Integer)
type RealCoord    = (Double, Double)
data HilbertIndex = HI { getMaxi :: Double, getHilbert :: M.Map HilbertCoord Int }

-- Testing

main :: IO ()
main = newStdGen >>= putStrLn
                   . doc
                   . map (pretty *** map pretty)
                   . map (\(x,ys) -> (x, take 3 (sortBy (comparing (manhattan x)) ys)))
                   . map (\(x,ys) -> (x, filter (/= x) ys))
                   . map (embiggen *** map embiggen)
                   . (centriful 6 . sortBy (comparing (index (hIndex 8)))
                   . take 200
                   . catMaybes
                   . map pairUp -- Random Pairs of numbers
                   . chunksOf 2
                   . randomRs (0,1))
  where
  doc :: [(String, [String])] -> String
  doc pairs = [qq|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
  <html>
    <head> <title>Hilbert Index</title> </head>
    <body style="margin: 0; padding: 50px;">
      <canvas width="1000" height="1000" id="canvas"> </canvas>
      <script>
        var c = document.getElementById('canvas').getContext('2d');

        {unlines $ map triangle pairs}
      </script> </body> </html> |]

embiggen :: (Double, Double) -> (Double, Double)
embiggen = (*1000) *** (*1000)

triangle :: (String, [String]) -> String
triangle (a,[x,y,z]) = [qq|
  var color1 = 110 + Math.floor( Math.random() * 100);
  var color2 = 50 + Math.floor( Math.random() * 100);
  var color3 = 10 + Math.floor( Math.random() * 100);

  c.fillStyle = 'rgba(' + color1 + ',' + color2 + ',' + color3 + ',0.9)';
  c.beginPath();
  c.arc({a}, 10, 0, 2 * Math.PI, false);
  c.fill();

  c.fillStyle = 'rgba(' + color1 + ',' + color2 + ',' + color3 + ',0.3)';
  c.beginPath();
  c.moveTo({x});
  c.lineTo({y});
  c.lineTo({z});
  c.closePath();
  c.fill();
  |]
triangle _ = ""

manhattan :: Num a => (a, a) -> (a, a) -> a
manhattan (x1,y1) (x2,y2) = abs (x2 - x1) + abs (y2 - y1)

pretty :: RealCoord -> String
pretty (a,b) = printf "%0.4f,%0.4f" a b

centriful :: Int -> [a] -> [(a,[a])]
centriful delta list = zip (drop (div delta 2) list) (chunky delta list)

chunky :: Int -> [a] -> [[a]]
chunky delta list = map (take delta) (tails list)

pairUp :: [x] -> Maybe (x,x)
pairUp [a,b] = Just (a,b)
pairUp _     = Nothing

-- Algo

(+>) :: (Num t, Num t1) => (t, t1) -> (t, t1) -> (t, t1)
(a,b) +> (c,d) = (a+c, b+d)

base :: [HilbertCoord]
base = [(0,1),(1,0),(0,-1)]

build :: [HilbertCoord] -> [HilbertCoord]
build x = l $ n x ++ o ++ r (r (l (x ++ o ++ x) ++ o ++ n x))

o :: [HilbertCoord]
o = [(1,0)]

l, r, n :: [HilbertCoord] -> [HilbertCoord]
l = map anticlockwise
r = map clockwise
n = reverse

clockwise, anticlockwise :: (Eq t1, Eq t, Num t1, Num t) => (t1, t) -> (t, t1)

clockwise      (0,y) = (y, 0)
clockwise      (x,0) = (0,-x)
clockwise      _     = error "Should only match zero cases"

anticlockwise  (0,y) = (-y,0)
anticlockwise  (x,0) = (0, x)
anticlockwise  _     = error "Should only match zero cases"

-- Index assumes all points are in the range 0,0 <-> 1,1
index :: HilbertIndex -> RealCoord -> Int
index hi (x,y) = fromMaybe 0 $ M.lookup (sx,sy) (getHilbert hi)
  where
  sx, sy :: Integer
  sx = floor (mi * x)
  sy = floor (mi * y)
  mi = getMaxi hi

hIndex :: Int -> HilbertIndex
hIndex resolution = HI (fromIntegral maxi) hilbert
  where
  maxi :: Int
  maxi = 2 ^ resolution

  hilbert :: M.Map HilbertCoord Int
  hilbert = M.fromList $ flip zip [0..] $ scanl (+>) (0,0) (iterate build base !! resolution)

	{-# LANGUAGE FlexibleInstances #-}
	{-# LANGUAGE TemplateHaskell #-}
	{-# LANGUAGE QuasiQuotes #-}

	import Data.Maybe (fromMaybe, catMaybes)
	import Data.List (tails, sortBy)
	import Data.Ord (comparing)
	import Data.List.Split
	import Text.Printf
	import Text.InterpolatedString.Perl6
	import Control.Arrow ((***))
	import System.Random
	import qualified Data.Map as M

	type HilbertCoord = (Integer, Integer)
	type RealCoord = (Double, Double)
	data HilbertIndex = HI { getMaxi :: Double, getHilbert :: M.Map HilbertCoord Int }

	-- Testing

	main :: IO ()
	main = newStdGen >>= putStrLn
	. doc
	. map (pretty *** map pretty)
	. map (\(x,ys) -> (x, take 3 (sortBy (comparing (manhattan x)) ys)))
	. map (\(x,ys) -> (x, filter (/= x) ys))
	. map (embiggen *** map embiggen)
	. (centriful 6 . sortBy (comparing (index (hIndex 8)))
	. take 200
	. catMaybes
	. map pairUp -- Random Pairs of numbers
	. chunksOf 2
	. randomRs (0,1))
	where
	doc :: [(String, [String])] -> String
	doc pairs = [qq\|<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">
	<html>
	<head> <title>Hilbert Index</title> </head>
	<body style="margin: 0; padding: 50px;">
	<canvas width="1000" height="1000" id="canvas"> </canvas>
	<script>
	var c = document.getElementById('canvas').getContext('2d');

	{unlines $ map triangle pairs}
	</script> </body> </html> \|]

	embiggen :: (Double, Double) -> (Double, Double)
	embiggen = (1000) ** (*1000)

	triangle :: (String, [String]) -> String
	triangle (a,[x,y,z]) = [qq\|
	var color1 = 110 + Math.floor( Math.random() * 100);
	var color2 = 50 + Math.floor( Math.random() * 100);
	var color3 = 10 + Math.floor( Math.random() * 100);

	c.fillStyle = 'rgba(' + color1 + ',' + color2 + ',' + color3 + ',0.9)';
	c.beginPath();
	c.arc({a}, 10, 0, 2 * Math.PI, false);
	c.fill();

	c.fillStyle = 'rgba(' + color1 + ',' + color2 + ',' + color3 + ',0.3)';
	c.beginPath();
	c.moveTo({x});
	c.lineTo({y});
	c.lineTo({z});
	c.closePath();
	c.fill();
	\|]
	triangle _ = ""

	manhattan :: Num a => (a, a) -> (a, a) -> a
	manhattan (x1,y1) (x2,y2) = abs (x2 - x1) + abs (y2 - y1)

	pretty :: RealCoord -> String
	pretty (a,b) = printf "%0.4f,%0.4f" a b

	centriful :: Int -> [a] -> [(a,[a])]
	centriful delta list = zip (drop (div delta 2) list) (chunky delta list)

	chunky :: Int -> [a] -> [[a]]
	chunky delta list = map (take delta) (tails list)

	pairUp :: [x] -> Maybe (x,x)
	pairUp [a,b] = Just (a,b)
	pairUp _ = Nothing

	-- Algo

	(+>) :: (Num t, Num t1) => (t, t1) -> (t, t1) -> (t, t1)
	(a,b) +> (c,d) = (a+c, b+d)

	base :: [HilbertCoord]
	base = [(0,1),(1,0),(0,-1)]

	build :: [HilbertCoord] -> [HilbertCoord]
	build x = l $ n x ++ o ++ r (r (l (x ++ o ++ x) ++ o ++ n x))

	o :: [HilbertCoord]
	o = [(1,0)]

	l, r, n :: [HilbertCoord] -> [HilbertCoord]
	l = map anticlockwise
	r = map clockwise
	n = reverse

	clockwise, anticlockwise :: (Eq t1, Eq t, Num t1, Num t) => (t1, t) -> (t, t1)

	clockwise (0,y) = (y, 0)
	clockwise (x,0) = (0,-x)
	clockwise _ = error "Should only match zero cases"

	anticlockwise (0,y) = (-y,0)
	anticlockwise (x,0) = (0, x)
	anticlockwise _ = error "Should only match zero cases"

	-- Index assumes all points are in the range 0,0 <-> 1,1
	index :: HilbertIndex -> RealCoord -> Int
	index hi (x,y) = fromMaybe 0 $ M.lookup (sx,sy) (getHilbert hi)
	where
	sx, sy :: Integer
	sx = floor (mi * x)
	sy = floor (mi * y)
	mi = getMaxi hi

	hIndex :: Int -> HilbertIndex
	hIndex resolution = HI (fromIntegral maxi) hilbert
	where
	maxi :: Int
	maxi = 2 ^ resolution

	hilbert :: M.Map HilbertCoord Int
	hilbert = M.fromList $ flip zip [0..] $ scanl (+>) (0,0) (iterate build base !! resolution)