(C) Roger Whittaker 2015
roger@disruptive.org.uk
Free software licenced under the GPL

> module Pgrams
> ( Pgram(..)
> , Cart(..)
> , dimen
> , xy
> , tocart
> , plus
> , minus
> , widths
> , bases
> )

> where

> data Pgram = Pgram { cords :: [Int]         -- the n co-ordinates
>                    , spans :: (Int, Int)    -- the two spanning directions
>                    } deriving (Show)

> data Cart  =  Cart { p0 :: (Double, Double) -- base
>                    , p1 :: (Double, Double) -- first span
>                    , p2 :: (Double, Double) -- sum of spans
>                    , p3 :: (Double, Double) -- second span
>                    } deriving (Show)

for example:

*Pgrams> let p = Pgram [1, 0, 2, 1, 3] (0, 1)
*Pgrams> p
Pgram {cords = [1,0,2,1,3], spans = (0,1)}
*Pgrams> tocart p
Cart {p0 = (-0.5000000000000007,-2.2653842965929876),
      p1 = (0.49999999999999944,-2.2653842965929876),
      p2 = (0.8090169943749469,-1.314327780297834),
      p3 = (-0.19098300562505321,-1.314327780297834)}
*Pgrams> dimen p
5


> dimen :: Pgram -> Int
> dimen = length . cords
>
> widths :: Integral t => t -> [t]
> widths n = [x+1 | x <- [0..(((n-1) `div` 2)-1)]]

*Pgrams> widths 3
[1]
*Pgrams> widths 4
[1]
*Pgrams> widths 5
[1,2]
*Pgrams> widths 6
[1,2]
*Pgrams> widths 7
[1,2,3]
*Pgrams> widths 8
[1,2,3]

> cosines :: Int -> [Double]
> cosines n =  map cos $ piby n

*Pgrams> rlist 4 (cosines 4)
[1.0,0.0,-1.0,0.0]
*Pgrams> rlist 4 (cosines 5)
[1.0,0.309,-0.809,-0.809,0.309]
*Pgrams> rlist 4 (cosines 6)
[1.0,0.5,-0.5,-1.0,-0.5,0.5]

> sines :: Int -> [Double]
> sines n = map sin $ piby n

*Pgrams> rlist 4 (sines 4)
[0.0,1.0,0.0,-1.0]
*Pgrams> rlist 4 (sines 5)
[0.0,0.9511,0.5878,-0.5878,-0.9511]
*Pgrams> rlist 4 (sines 6)
[0.0,0.866,0.866,0.0,-0.866,-0.866]

> cs :: Int -> Int -> Double
> cs n k = ((cosines n)!!k) / ((sines n)!! k)
>
> s :: Int -> Int -> Double
> s n k  = 1/((sines n)!!k)

> rounding :: (Fractional a, Integral b, RealFrac a1) => b -> a1 -> a
> rounding n x = (fromIntegral (round (x * 10 ^n)))/10^n
>
> rlist k lst = map (rounding k) lst
> rtup k (x,y) = (rlist k x, rlist k y)

> bb :: Int -> [([Double], [Double])]
> bb n  = [((cosines n) `minus` (map (*(cs n k)) (sines n)), map (* s n k) (sines n)) | k <- widths n]

> bases :: Int -> [([Double], [Double])]
> bases n = map (rtup 12) (bb n)

> piby :: Int -> [Double]
> piby n = map ( * ((2 * pi )/(fromIntegral n))) (map fromIntegral [0..n-1])

> xy :: Integral a => [a] -> (Double, Double)
> xy list = ( sum $ zipWith (*) (cosines (fromIntegral (length list))) (map fromIntegral list)
>           , sum $ zipWith (*)   (sines (fromIntegral (length list))) (map fromIntegral list)
>           )

> fix :: Num b => Pgram -> [b]
> fix x = map fromIntegral (cords x)

> zeros :: [Integer]
> zeros = 0:zeros

> plus :: Num c => [c] -> [c] -> [c]
> plus l1 l2 = zipWith (+) l1 l2

> minus :: Num c => [c] -> [c] -> [c]
> minus l1 l2 = zipWith (+) l1 ((map negate) l2)

> base :: Int -> Int -> [Integer]
> base n r = (take s zeros) ++ [1] ++ take ((n - s) - 1 ) zeros
>             where s = r `mod` n

*Pgrams> base 5 0
[1,0,0,0,0]
*Pgrams> base 5 1
[0,1,0,0,0]
*Pgrams> base 5 2
[0,0,1,0,0]


> tocart :: Pgram -> Cart
> tocart p = Cart (xy (fix p))
>                 (xy ((fix p) `plus` (map fromIntegral u)))
>                 (xy ((fix p) `plus` (map fromIntegral v)))
>                 (xy ((fix p) `plus` (map fromIntegral w)))
>                 where
>                 u = base (dimen p) (fst (spans p))
>                 w = base (dimen p) (snd (spans p))
>                 v = u `plus` w