sordina/hilbert-color.hs

## hilbert-color.hs

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

import Text.InterpolatedString.Perl6
import Text.Printf

type Coord         = (Integer, Integer)
type HilbertLookup = [Coord]

main :: IO ()
main = putStrLn $ document $ zip [0..] $ scanl (+>) (0,0) (iterate build base !! 6)

document :: [(Int,Coord)] -> String
document 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: 0;">
    <canvas width="1000" height="1000" id="canvas"> </canvas>
    <script>
      var c = document.getElementById('canvas').getContext('2d');
      $paths
    </script> </body> </html> |] where paths = unlines (map (path (length pairs)) pairs)

path :: Int -> (Int, Coord) -> String
path len (index, (x,y)) = [qq|
  c.beginPath();
  c.rect({x*5}, {y*5}, 5, 5);
  c.fillStyle = '{c}';
  c.fill(); |]
  where c :: String
        c = color (f index / f len)

color :: Double -> String
color x | x < (1/3) = [qq|rgba({s x 0},    0,          {v x (1/3)},1)|]
        | x < (2/3) = [qq|rgba({v x (3/3)},{s x (1/3)},0,          1)|]
        | otherwise = [qq|rgba(0,          {v x (3/3)},{s x (2/3)},1)|]
  where
  s, v :: Double -> Double -> String
  s m t = printf "%d" (floor ((m - t) * 3 * 200) :: Int)
  v m t = printf "%d" (floor ((t - m) * 3 * 200) :: Int)

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

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

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

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

l, r, n :: [Coord] -> [Coord]
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"

-- Specialised conversion
f :: Int -> Double
f = fromIntegral

-- Index functions
{-

hIndex :: (Bounded a, Fractional a) => HilbertLookup -> a -> a -> Int
hIndex = undefined

foo = print $ map bar $ zip [0..] $ take 7 $ iterate build base
  where
  bar (x,i) = (x, length h, maximum (map fst h), minimum (map fst h), maximum (map snd h), minimum (map snd h))
    where
    h = scanl (+>) (0,0) i

    -- [*Main] λ take 8 $ map (4^) [1..]
    -- [*Main] λ take 8 $ map (pred . (2^)) [1..]

baz :: Data -> Lookup DataPoint [DataPoint]
baz = undefined

-}

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

	import Text.InterpolatedString.Perl6
	import Text.Printf

	type Coord = (Integer, Integer)
	type HilbertLookup = [Coord]

	main :: IO ()
	main = putStrLn $ document $ zip [0..] $ scanl (+>) (0,0) (iterate build base !! 6)

	document :: [(Int,Coord)] -> String
	document 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: 0;">
	<canvas width="1000" height="1000" id="canvas"> </canvas>
	<script>
	var c = document.getElementById('canvas').getContext('2d');
	$paths
	</script> </body> </html> \|] where paths = unlines (map (path (length pairs)) pairs)

	path :: Int -> (Int, Coord) -> String
	path len (index, (x,y)) = [qq\|
	c.beginPath();
	c.rect({x5}, {y5}, 5, 5);
	c.fillStyle = '{c}';
	c.fill(); \|]
	where c :: String
	c = color (f index / f len)

	color :: Double -> String
	color x \| x < (1/3) = [qq\|rgba({s x 0}, 0, {v x (1/3)},1)\|]
	\| x < (2/3) = [qq\|rgba({v x (3/3)},{s x (1/3)},0, 1)\|]
	\| otherwise = [qq\|rgba(0, {v x (3/3)},{s x (2/3)},1)\|]
	where
	s, v :: Double -> Double -> String
	s m t = printf "%d" (floor ((m - t) * 3 * 200) :: Int)
	v m t = printf "%d" (floor ((t - m) * 3 * 200) :: Int)

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

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

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

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

	l, r, n :: [Coord] -> [Coord]
	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"

	-- Specialised conversion
	f :: Int -> Double
	f = fromIntegral

	-- Index functions
	{-

	hIndex :: (Bounded a, Fractional a) => HilbertLookup -> a -> a -> Int
	hIndex = undefined

	foo = print $ map bar $ zip [0..] $ take 7 $ iterate build base
	where
	bar (x,i) = (x, length h, maximum (map fst h), minimum (map fst h), maximum (map snd h), minimum (map snd h))
	where
	h = scanl (+>) (0,0) i

	-- [*Main] λ take 8 $ map (4^) [1..]
	-- [*Main] λ take 8 $ map (pred . (2^)) [1..]

	baz :: Data -> Lookup DataPoint [DataPoint]
	baz = undefined

	-}