module Complex where

import qualified Graphics.UI.Threepenny as UI
import Data.Complex
import Text.XML
import Prelude hiding (readFile, writeFile)
import Text.XML as X
import Text.XML.Cursor as C
import qualified Data.Text as T
import Text.Read
import Data.List
import Data.Maybe
import Data.Either
import TwoD
import Scheme

-- (* Copyright (c) 2009, 2008, 2007, 2006 by André van Meulebrouck.  All rights reserved worldwide. *)

-- module PlottingAndScheming.Complex

-- open Microsoft.FSharp.Math
-- open PlottingAndScheming.TwoD
-- open System
-- open System.ComponentModel
-- open System.IO
-- open System.Collections.Generic
-- open System.IO.IsolatedStorage
-- open System.Numerics
-- open System.Text.RegularExpressions
-- open System.Windows
-- open System.Windows.Controls
-- open System.Windows.Input
-- open System.Windows.Markup
-- open System.Windows.Media
-- open System.Windows.Media.Imaging
-- open System.Windows.Shapes
-- open System.Xml.Linq

-- //the goal of this module is to do complex plane fractals in an OOP style

--I don't think the below is used; it looks like it was a coding experiment

-- type 'a options =
--     | Empty
--     | Contents of 'a
--     | Error of string

-- type iteratedSet =
--     | Mandelbrot of complex Option
--     | Julia of complex
--     | NewtonBOF of float

data IteratedSet
    = ItsMandelbrot (Maybe (Complex Double))
    | ItsJulia (Complex Double)
    | ItsNewtonBoF Double
    deriving (Show)

-- type fateOrbitNumbering =
--     | Down
--     | Up

data FateOrbitNumbering
    = FonUp
    | FonDown
    deriving (Show)

-- type iteratedFateAlgorithm =
--     | Remainder
--     | Quotient

data IteratedFateAlgorithm
    = IfaRemainder
    | IfaQuotient
    deriving (Show)

-- type orbitPattern =
--     | Fixpoint
--     | Oscillate

data OrbitPattern
    = ObpFixpoint
    | ObpOscillate
    deriving (Show)

-- //equations

-- type newtonEquationBOF =
--     {   f : (complex -> complex);
--         f' : (complex -> complex); }

data NewtonEquationBoF = NewtonEquationBoF
    { nebf :: Complex Double -> Complex Double
    , nebf' :: Complex Double -> Complex Double }
    -- deriving (Show) --to do:  research error that disallows show

-- type newtonEquation =
--     {   f : (complex -> complex -> complex);
--         f' : (complex -> complex -> complex); }

data NewtonEquation = NewtonEquation
    { neqf :: Complex Double -> Complex Double -> Complex Double
    , neqf' :: Complex Double -> Complex Double -> Complex Double }
    -- deriving (Show)

-- type complexEquation =
--     | Generic of (complex -> complex -> complex)
--     | Phoenix of (complex -> complex -> complex -> complex)
--     | NewtonBOF of newtonEquationBOF
--     | Newton of newtonEquation

data ComplexEquation
    = CeqGeneric (Complex Double -> Complex Double -> Complex Double)
    | CeqPhoenix (Complex Double -> Complex Double -> Complex Double -> Complex Double)
    | CeqNewtonBoF NewtonEquationBoF
    | CeqNewton NewtonEquation
    -- deriving (Show)

-- type equation = {
--     name : string;
--     equation : complexEquation; }

-- let complexOne = complex 1.0 0.0

complexOne :: Complex Double
complexOne = 1.0 :+ 0.0

-- let complexTwo = complex 2.0 0.0

complexTwo :: Complex Double
complexTwo = 2.0 :+ 0.0

-- let complexThree = complex 3.0 0.0

complexThree :: Complex Double
complexThree = 0.0 :+ 1.0

-- let complexI = complex 0.0 1.0

complexI :: Complex Double
complexI = 0.0 :+ 1.0

-- let complexZero = complex 0.0 0.0

complexZero :: Complex Double
complexZero = 0.0 :+ 0.0

-- let (equations : equation list) = [
--     {   name = "mandelbrot";
--         equation =
--             complexEquation.Generic
--                 (fun c z ->
--                     (pown z 2) + c); };
--     {   name = "San Marco dragon";
--         equation =
--             complexEquation.Generic
--                 (fun c z ->
--                     c * (pown (complexOne - z) 2)); };
--     {   name = "z cubed";
--         equation =
--             complexEquation.Generic
--                 (fun c z ->
--                     (pown z 3) + c); };
--     {   name = "cos";
--         equation =
--             complexEquation.Generic
--                 (fun c z ->
--                     (cos z) + c); };
--     {   name = "phoenix";
--         equation =
--             complexEquation.Phoenix
--                 (fun c z p ->
--                     z * z +
--                     (complex c.r 0.0) +
--                     (c.i * p)); };
--     {   name = "potts-spins model i";
--         equation =
--             complexEquation.Generic
--                 (fun c z ->
--                     (pown (((z * z) + c - complexOne) / (2.0 * z + c - complexTwo)) 2)); }
--     {   name = "potts-spins model ii";
--         equation =
--             complexEquation.Generic
--                 (fun c z ->
--                     let cmpCminus1 = c - complexOne
--                     let cmpCminus2 = c - complexTwo
--                     let cmpCminus1timesCminus2 = cmpCminus1 * cmpCminus2
--                     let cmpCsqMinus3cPlus3 = c * c - (complexThree * c) + complexThree
--                     let cmpZsq = z * z
--                     let newZ =
--                         ((cmpZsq * z) +
--                             (complexThree * cmpCminus1 * z) + cmpCminus1timesCminus2) /
--                         (complexThree * cmpZsq +
--                             (complexThree * cmpCminus2 * z) + cmpCsqMinus3cPlus3)
--                     newZ * newZ); };
--     {   name = "critter";
--         equation =
--             complexEquation.NewtonBOF {
--                 f =
--                     (fun z ->
--                         (z - complexOne) * (z * z + z + (complex 0.5 0.0)));
--                 f' =
--                     (fun z ->
--                         ((z - complexOne) * ((complexTwo * z) + complexOne)) +
--                         (z * z) + z + (complex 0.5 0.0)); }; };
--     {   name = "plate 27";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 3) - c);
--                 f' =
--                     (fun c z -> 3.0 * (pown z 2)); }; };
--     {   name = "plate 28";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 3) - (2.0 * z) + c);
--                 f' =
--                     (fun c z -> 3.0 * (pown z 2) - complexTwo); }; };
--     {   name = "z^2";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 2) + c);
--                 f' =
--                     (fun c z -> 2.0 * z); }; };
--     {   name = "z^3";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 3) + c);
--                 f' =
--                     (fun c z -> 3.0 * (pown z 2)); }; };
--     {   name = "z^4";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 4) + c);
--                 f' =
--                     (fun c z -> 4.0 * (pown z 3)); }; };
--     {   name = "z^5";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 5) + c);
--                 f' =
--                     (fun c z -> 5.0 * (pown z 4)); }; };
--     {   name = "z^6";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 6) + c);
--                 f' =
--                     (fun c z -> 6.0 * (pown z 5)); }; };
--     {   name = "z^7";
--         equation =
--             complexEquation.Newton {
--                 f =
--                     (fun c z -> (pown z 7) + c);
--                 f' =
--                     (fun c z -> 7.0 * (pown z 6)); }; };
--     ]

equations :: [(String, ComplexEquation)]
equations =
    [ ("mandelbrot", CeqGeneric (\c z -> (z :: Complex Double)**2 + (c :: Complex Double)))
    , ("San Marco dragon", CeqGeneric (\ c z -> c * (complexOne - z)**2))
    , ("z cubed", CeqGeneric (\c z -> z**3 + c))
    , ("cos", CeqGeneric (\c z -> cos z + c))
    , ("phoenix", CeqPhoenix (\c z p -> z * z + ((realPart c) :+ 0.0) + ((0.0 :+ imagPart c) * p)))
    , ("potts-spins model i", CeqGeneric (\c z -> (((z * z) + c - complexOne) / (2.0 * z + c - complexTwo))**2))
    , ("potts-spins model ii", CeqGeneric
        (\c z ->
            let cmpCminus1 = c - complexOne
                cmpCminus2 = c - complexTwo
                cmpCminus1timesCminus2 = cmpCminus1 * cmpCminus2
                cmpCsqMinus3cPlus3 = c * c - (complexThree * c) + complexThree
                cmpZsq = z * z
                newZ =
                    ((cmpZsq * z) +
                        (complexThree * cmpCminus1 * z) + cmpCminus1timesCminus2) /
                    (complexThree * cmpZsq +
                        (complexThree * cmpCminus2 * z) + cmpCsqMinus3cPlus3)
            in newZ * newZ))
    , ("critter", CeqNewtonBoF
            (NewtonEquationBoF
                { nebf = (\z -> (z - complexOne) * (z * z + z + (0.5 :+ 0.0)))
                , nebf' = (\z -> ((z - complexOne) * ((complexTwo * z) + complexOne)) + (z * z) + z + (0.5 :+ 0.0)) } ))
    , ("plate 27", CeqNewton (NewtonEquation { neqf = (\c z -> z**3 - (c :: Complex Double)), neqf' = (\c z -> 3.0 * (z**2)) } ))
    , ("plate 28", CeqNewton (NewtonEquation { neqf = (\c z -> z**3 - (2.0 * z) + c), neqf' = (\c z -> 3.0 * z**2 - complexTwo)}))
    , ("z^3", CeqNewton (NewtonEquation { neqf = (\c z -> z**3 + c), neqf' = (\c z -> 3.0 * z**2)}))
    , ("z^4", CeqNewton (NewtonEquation { neqf = (\c z -> z**4 + c), neqf' = (\c z -> 4.0 * z**3)}))
    , ("z^5", CeqNewton (NewtonEquation { neqf = (\c z -> z**5 + c), neqf' = (\c z -> 5.0 * z**4)}))
    , ("z^6", CeqNewton (NewtonEquation { neqf = (\c z -> z**6 + c), neqf' = (\c z -> 6.0 * z**5)}))
    , ("z^7", CeqNewton (NewtonEquation { neqf = (\c z -> z**7 + c), neqf' = (\c z -> 7.0 * z**6)}))
    ]

-- let equationFind name =
--     let rec iter lst =
--         match lst with
--         | [] -> None
--         | h :: t ->
--             if h.name = name then
--                 Some h.equation
--             else
--                 iter t
--     iter equations

findEquation :: [ (String, ComplexEquation) ] -> String -> Maybe ComplexEquation
findEquation alist tgt =
    case (find (\(c, _) -> c == tgt) alist) of
        Just (_, e) -> Just e
        Nothing -> Nothing

-- type iteratedFateColoring = {
--     palette : Color array;
--     orbitNumbering : fateOrbitNumbering;
--     algorithm : iteratedFateAlgorithm; } with
--     member x.getColor (iterations : int) (iterationsMax : int) =
--         let iterationsMax = iterationsMax - 1
--         let len = x.palette.Length
--         let i =
--             match x.orbitNumbering with
--             | fateOrbitNumbering.Up -> iterations
--             | fateOrbitNumbering.Down -> (iterationsMax - iterations)
--         match x.algorithm with
--         | iteratedFateAlgorithm.Quotient ->
--             //to do:  get rid of hardcoded value, make union with len or #
--             let numberOfGroups = 35
--             x.palette.[(i / numberOfGroups) % len]
--         | iteratedFateAlgorithm.Remainder ->
--             x.palette.[i % len]

data IteratedFateColoring = IteratedFateColoring
    { ifcPalette :: [UI.Color]
    , ifcOrbitNumbering :: FateOrbitNumbering
    , ifcAlgorithm :: IteratedFateAlgorithm }
    deriving (Show)

-- type iteratedSurvivor = {
--     iterations : int; //to do:  remove this
--     coloring : iteratedFateColoring; } with

data IteratedSurvivor = IteratedSurvivor
    { itsIterations :: Int
    , itsColoring :: IteratedFateColoring }
    deriving (Show)

--     member x.checkFate (iterations : int) (iterationsMax : int) =
--         if iterations >= iterationsMax - 1 then
--             Some (x.coloring.getColor iterations iterationsMax)
--         else
--             None

checkFate :: Int -> Int -> Maybe UI.Color
checkFate iterations iterationsMax = undefined

-- type iteratedEscapee = {
--     threshold : double;
--     coloringInfinity : iteratedFateColoring;
--     coloringBiomorph : iteratedFateColoring option; } with

data IteratedEscapee = IteratedEscapee
    { iteThreshold :: Complex Double
    , iteColoringInfinity :: IteratedFateColoring
    , iteBiomorph :: Maybe IteratedFateColoring }
    deriving (Show)

--     member x.checkFate (z : complex) (iterations : int) (iterationsMax : int) =
--         let outOfBounds = z.Magnitude > x.threshold
--         match x.coloringBiomorph, outOfBounds with
--         | Some b, true ->
--             let i = z.i
--             let r = z.r
--             if i * i <= x.threshold || r * r <= x.threshold then
--                 Some (b.getColor iterations iterationsMax)
--             else
--                 Some (x.coloringInfinity.getColor iterations iterationsMax)
--         | None, true ->
--             Some (x.coloringInfinity.getColor iterations iterationsMax)
--         | _, false ->
--             None

checkFateEscapee :: Complex Double -> Int -> Int -> Maybe UI.Color
checkFateEscapee z iterations iterationsMax = undefined

-- type iteratedFixpoint = {
--     fixpoint : complex;
--     epsilon : complex option;
--     coloring : iteratedFateColoring; } with

data IteratedFixpoint = IteratedFixpoint
    { itfFixpoint :: Complex Double
    , itfEpsilon :: Maybe (Complex Double)
    , itfColoring :: Maybe (Complex Double) }
    deriving (Show)

--     member x.checkFate (z : complex) (iterations : int) (iterationsMax : int) =
--         if z = x.fixpoint then
--             Some (x.coloring.getColor iterations iterationsMax)
--         else
--             None

checkFateFixPoint :: Complex Double -> Int -> Int -> Maybe UI.Color
checkFateFixPoint z iterations iterationsMax = undefined

-- type iteratedCriticalValue = {
--     criticalValue : complex;
--     iteratedCriticalValue: complex;
--     comparison : float -> float -> bool;
--     epsilon : float option;
--     coloring : iteratedFateColoring; } with

data IteratedCriticalValue = IteratedCriticalValue
    { itcCriticalValue :: Complex Double
    , itcIteratedCriticalValue :: Complex Double
    , itcComparison :: Double -> Double -> Bool
    , itcEpsilon :: Maybe Double
    , itcColoring :: IteratedFateColoring }
    -- deriving (Show)

--     member x.checkFate (z : complex) (iterations : int) (iterationsMax : int) =
--         match x.epsilon with
--         | None ->
--             if z = x.iteratedCriticalValue then
--                 Some (x.coloring.getColor iterations iterationsMax)
--             else
--                 None
--         | Some e ->
--             if x.comparison (z - x.iteratedCriticalValue).Magnitude e then
--                 Some (x.coloring.getColor iterations iterationsMax)
--             else
--                 None

checkFateCriticalValue :: Complex Double -> Int -> Int -> Maybe UI.Color
checkFateCriticalValue z iterations iterationsMax = undefined

-- let xname n = XName.op_Implicit(n)

-- //to do:  make a union with none, value, and parse error
-- let fetch tryParse (xml : XElement) name =
--     let x = xml.Element (xname name)
--     match x with
--     | null -> None
--     | _ ->
--         let s, v = tryParse (x.Value)
--         if s then
--             Some v
--         else
--             failwith (name + " parse failure in " + (x.ToString ()))

-- let fetchDouble = fetch Double.TryParse
-- //let fetchBoolean = fetch Boolean.TryParse
-- let fetchInt : XElement -> string -> Int32 option = fetch Int32.TryParse
-- let fetchElement (el : XElement) str = el.Element (xname str)
-- let fetchAttribute (el : XElement) str =
--     let at = el.Attribute (xname str)
--     if at = null then
--         None
--     else
--         Some at.Value

-- type plotCoordinates = {
--     xml : XElement;
--     swapXY : bool option;
--     coords : coordinates; } with

data PlotCoordinates = PlotCoordinates
    { plcXml :: String
    , plcSwapXY :: Maybe Bool
    , plcCoords :: Coordinates
    }
    deriving (Show)

--     static member create (xml : XElement) =
--         let swapXY =
--             Option.bind
--                 (fun v ->
--                     let b, v = Boolean.TryParse v
--                     if b then Some v else None)
--                 (fetchAttribute xml "swapXY")
--         let x = xml.Element (xname "x")
--         let pixelsX = fetchDouble x "pixels"
--         let pixelsX =
--             match pixelsX with
--             | Some x -> Some (x - 1.0)
--             | None -> None
--         let centerX = fetchDouble x "center"
--         let minX = if centerX.IsNone then fetchDouble x "min" else None
--         let maxX = if centerX.IsNone then fetchDouble x "max" else None
--         let y = xml.Element (xname "y")
--         let centerY = fetchDouble y "center"
--         let minY = if centerY.IsNone then fetchDouble y "min" else None
--         let maxY = if centerY.IsNone then fetchDouble y "max" else None
--         let pixelsY = fetchDouble y "pixels"
--         let pixelsY =
--             match pixelsY with
--             | Some y -> Some (y - 1.0)
--             | None -> None
--         let ppu = fetchDouble xml "ppu"
--         //call coordinate constructor
--         let coords =
--             match centerX, centerY with
--             | Some x, Some y ->
--                 let centerX = x * 1.0<units>
--                 let centerY = y * 1.0<units>
--                 let ppu = ppu.Value * 1.0<pixels/units>
--                 let pixelsX = pixelsX.Value * 1.0<pixels>
--                 let pixelsY = pixelsY.Value * 1.0<pixels>
--                 let coords =
--                     coordinates.originFromPPU
--                         centerX
--                         centerY
--                         ppu
--                         pixelsX
--                         pixelsY
--                 coords
--             | None, None ->
--                 match minX, minY, maxX, maxY with
--                 | Some minX, Some minY, Some maxX, Some maxY ->
--                     let minX = minX * 1.0<units>
--                     let maxX = maxX * 1.0<units>
--                     let minY = minY * 1.0<units>
--                     let maxY = maxY * 1.0<units>
--                     let pixelsX = pixelsX.Value * 1.0<pixels>
--                     let pixelsY = pixelsY.Value * 1.0<pixels>
--                     let coords =
--                         coordinates.extremas
--                             minX
--                             maxX
--                             minY
--                             maxY
--                             pixelsX
--                             pixelsY
--                     coords
--                 | _, _, _, _ -> failwith "bad coordinate specification for extremas"
--             | _, _ -> failwith "unexpected coordinate specifications"
--         {   xml = xml;
--             swapXY = swapXY;
--             coords = coords; }

ctorPlotCoordinates :: Double -> Double -> Double -> Double -> Double -> Double -> PlotCoordinates
ctorPlotCoordinates = undefined

-- type plotPalettes = {
--     xml : XElement;
--     palettes : Color array array; } with
--     static member create (xml : XElement) =
--         let colors =
--             xml.Elements ()
--             |> Seq.map
--                 (fun e ->
--                     e.Elements ()
--                     |> Seq.map
--                         (fun e ->
--                             let el = e.FirstNode :?> XElement
--                             let name = el.Name.LocalName
--                             match name with
--                             | "name" ->
--                                 ColorConverter.ConvertFromString(el.Value) :?> Color
--                             | "rgb" ->
--                                 let r = el.Element (xname "red")
--                                 let g = el.Element (xname "green")
--                                 let b = el.Element (xname "blue")
--                                 let r = Convert.ToByte (r.Value)
--                                 let g = Convert.ToByte (g.Value)
--                                 let b = Convert.ToByte (b.Value)
--                                 let clr = Color.FromRgb(r, g, b)
--                                 clr
--                             | _ ->
--                                 failwith "bad color specification")
--                     |> Seq.toArray)
--             |> Seq.toArray
--         {   xml = xml;
--             palettes = colors; }
--     member x.palette n =
--         x.palettes.[n]

--to do

-- type xmlColoring = {
--     xml : XElement;
--     coloring : iteratedFateColoring; } with
--     static member fromXML (xml : XElement) (palettes : plotPalettes) =
--         let palette = fetchInt xml "palette"
--         let algorithm = xml.Element (xname "algorithm")
--         let algorithm =
--             match algorithm.Value with
--             | "remainder" -> iteratedFateAlgorithm.Remainder
--             | "quotient" -> iteratedFateAlgorithm.Quotient
--             | x -> failwith ("bad orbit numbering specification" + x)
--         let orbitNumbering = xml.Element (xname "orbitNumbering")
--         let orbitNumbering =
--             match orbitNumbering.Value with
--             | "up" -> fateOrbitNumbering.Up
--             | "down" -> fateOrbitNumbering.Down
--             | x -> failwith ("bad orbit numbering specification" + x)
--         let palette = palettes.palette palette.Value
--         let coloring =
--             {   palette = palette;
--                 algorithm = algorithm;
--                 orbitNumbering = orbitNumbering; }
--         {   xml = xml;
--             coloring = coloring; }

--to do

-- type xmlFateSurvivor = {
--     xml : XElement;
--     survivor : iteratedSurvivor; } with
--     static member fromXML (xml : XElement) (palettes : plotPalettes) =
--         let iterations = fetchInt xml "iterations"
--         let coloring = fetchElement xml "coloring"
--         let coloring = xmlColoring.fromXML coloring palettes
--         let survivor = {
--             iterations = iterations.Value;
--             coloring = coloring.coloring; }
--         {   xml = xml;
--             survivor = survivor; }

--to do

-- type xmlFateEscapee = {
--     xml : XElement;
--     escapee : iteratedEscapee; } with
--     static member fromXML (xml : XElement) (palettes : plotPalettes) =
--         let threshold = fetchDouble xml "threshold"
--         let infinity = fetchElement xml "infinity"
--         let biomorph = fetchElement xml "biomorph"
--         let coloringInfinity = fetchElement infinity "coloring"
--         let coloringInfinity = xmlColoring.fromXML coloringInfinity palettes
--         let coloringInfinity = coloringInfinity.coloring
--         let coloringBiomorph =
--             if biomorph = null then
--                 None
--             else
--                 let coloringBiomorph = fetchElement biomorph "coloring"
--                 let coloringBiomorph = xmlColoring.fromXML coloringBiomorph palettes
--                 Some coloringBiomorph.coloring
--         let escapee = {
--             threshold = threshold.Value;
--             coloringInfinity = coloringInfinity;
--             coloringBiomorph = coloringBiomorph;  }
--         {   xml = xml;
--             escapee = escapee; }

--to do

-- type xmlFateFixpoint = {
--     xml : XElement;
--     fixpoint : iteratedFixpoint; } with
--     static member fromXML (xml : XElement) (palettes : plotPalettes) =
--         let f = fetchElement xml "value"
--         let f =
--             if f = null then
--                 None
--             else
--                 schemeParseComplex f.Value
--         if f.IsNone then failwith "bad fixpoint"
--         let coloring = fetchElement xml "coloring"
--         let coloring = xmlColoring.fromXML coloring palettes
--         let coloring = coloring.coloring
--         let fixpoint =
--             {   fixpoint = f.Value;
--                 epsilon = None;
--                 coloring = coloring; }
--         {   xml = xml;
--             fixpoint = fixpoint; }

-- type iteratorMandelbrot = {
--     mutable z : complex option;
--     mutable c : complex option;
--     mutable iterations : int option;
--     set : iteratedSet;
--     equation : complex -> complex -> complex; } with

data IteratorMandelbrot = IteratorMandelbrot
    { itmZ :: Maybe (Complex Double)
    , itmC :: Maybe (Complex Double)
    , itmIterations :: Maybe Int
    , itmSet :: IteratedSet
    } deriving (Show)

--     static member create eq set =
--         match set with
--         | iteratedSet.Mandelbrot o ->
--             {z = None; c = None; iterations = None; set = set; equation = eq; }
--         | iteratedSet.Julia o ->
--             {z = None; c = Some o; iterations = None; set = set; equation = eq; }
--         | _ ->
--             failwith "not implemented yet"

--to do:  ctorIteratorMandelbrot

--     member x.init z =
--         x.iterations <- Some 0
--         match x.set with
--         | iteratedSet.Mandelbrot _ ->
--             x.z <- Some (complex 0.0 0.0)
--             x.c <- Some z
--             ()
--         | iteratedSet.Julia _ ->
--             x.z <- Some z
--             ()
--         | _ -> failwith "not implemented yet"

--to do:  init method

--     member x.next () =
--         match x.z, x.c with
--         | Some z, Some c ->
--             x.z <- Some (x.equation c z)
--         | _, _ ->
--             failwith "attempt to iterate before initialization"
--         match x.iterations with
--         | Some i ->
--             x.iterations <- Some (i + 1)
--         | None ->
--             failwith "attempt to iterate before initialization"
--         ()

--to do:  next method

-- type iteratorPhoenix = {
--     mutable p : complex option;
--     mutable z : complex option;
--     mutable c : complex option;
--     mutable iterations : int option;
--     set : iteratedSet;
--     equation : complex -> complex -> complex -> complex; } with

data IteratorPhoenix = IteratorPhoenix
    { itpP :: Maybe (Complex Double)
    , itpZ :: Maybe (Complex Double)
    , itpC :: Maybe (Complex Double)
    , itpIterations :: Maybe Int
    , itpSet :: IteratedSet
    , itpEquation :: Complex Double -> Complex Double -> Complex Double -> Complex Double }
    -- deriving (Show)

--     static member create eq set =
--         match set with
--         | iteratedSet.Mandelbrot o ->
--             {p = None; z = None; c = None; iterations = None; set = set; equation = eq; }
--         | iteratedSet.Julia o ->
--             {p = None; z = None; c = Some o; iterations = None; set = set; equation = eq; }
--         | _ ->
--             failwith "not implemented yet"

--to do:  ctorIteratorPhoenix

--     member x.init z =
--         x.iterations <- Some 0
--         x.p <- Some complexZero
--         match x.set with
--         | iteratedSet.Mandelbrot _ ->
--             x.z <- Some complexZero
--             x.c <- Some z
--             ()
--         | iteratedSet.Julia _ ->
--             x.z <- Some z
--             ()
--         | _ -> failwith "illegal set for phoenix iterator"

--to do:  initIteratorPhoenix

--     member x.next () =
--         match x.z, x.c, x.p with
--         | Some z, Some c, Some p ->
--             let previous = z
--             let nextZ = x.equation c z p
--             x.z <- Some nextZ
--             x.p <- Some previous
--         | _, _, _ ->
--             failwith "attempt to iterate before initialization"
--         match x.iterations with
--         | Some i ->
--             x.iterations <- Some (i + 1)
--         | None ->
--             failwith "attempt to iterate before initialization"
--         ()

-- type iteratorNewtonBOF = {
--     mutable z : complex option;
--     mutable iterations : int option;
--     f : complex -> complex;
--     f' : complex -> complex;
--     s : complex; } with

data IteratorNewtonBoF = IteratorNewtonBoF
    { inbZ :: Maybe (Complex Double)
    , inbIterations :: Maybe Int
    , inbF :: Complex Double -> Complex Double
    , inbF' :: Complex Double -> Complex Double
    , inbS :: Complex Double }
    -- deriving (Show)

--     static member create (eq : newtonEquationBOF) s =
--         {z = None; iterations = None; f = eq.f; f' = eq.f'; s = s}

--to do:  ctorIteratorNewtonBoF

--     member x.init z =
--         x.z <- Some z
--         x.iterations <- Some 0
--         ()

--to do:  init

--     member x.next () =
--         match x.z, x.s with
--         | Some z, s ->

--             x.z <- Some (z - ((x.f z) / ((x.f' z) + (s * complexI))))
--         | _, _ ->
--             failwith "attempt to iterate before initialization"
--         match x.iterations with
--         | Some i ->
--             x.iterations <- Some (i + 1)
--         | None ->
--             failwith "attempt to iterate before initilization"
--         ()

--to do:  next

-- type iteratorNewton = {
--     mutable z : complex option;
--     mutable iterations : int option;
--     mutable orbits : complex list;
--     f : complex -> complex -> complex;
--     f' : complex -> complex -> complex;
--     mutable c : complex option;
--     set : iteratedSet;} with

data IteratorNewton = IteratorNewton
    { itnZ :: Maybe (Complex Double)
    , itnIterations :: Maybe Int
    , itnOrbits :: [Complex Double]
    , itnf :: Complex Double -> Complex Double -> Complex Double
    , itnf' :: Complex Double -> Complex Double -> Complex Double
    , itnC :: Maybe (Complex Double)
    , itnSet :: IteratedSet }
    -- deriving (Show)

--     static member create (eq : newtonEquation) set =
--         let c =
--             match set with
--             | iteratedSet.Julia j ->
--                 Some j
--             | iteratedSet.Mandelbrot m ->
--                 m
--             | iteratedSet.NewtonBOF s ->
--                 failwith "inappropriate set argument for this type of newton"
--         {z = None; iterations = None; f = eq.f; f' = eq.f'; set = set; c = c; orbits = []}

--ctorIteratorNewton

--     member x.init z =
--         x.z <- Some z
--         x.iterations <- Some 0
--         match x.set with
--         | iteratedSet.Mandelbrot _ ->
--             x.z <- Some complexZero
--             x.c <- Some z
--             x.orbits <- []
--             ()
--         | iteratedSet.Julia _ ->
--             x.orbits <- []
--             x.z <- Some z
--             ()
--         | _ -> failwith "illegal set for this type of newton iterator"
--         ()

--to do

--     member x.next () =
--         match x.z, x.c with
--         | Some z, Some c ->
--             x.orbits <- z :: x.orbits
--             x.z <- Some (z - ((x.f c z) / ((x.f' c z))))
--         | _, _ ->
--             failwith "attempt to iterate before initialization"
--         match x.iterations with
--         | Some i ->
--             x.iterations <- Some (i + 1)
--         | None ->
--             failwith "attempt to iterate before initilization"
--         ()

-- type iterator =
--     | Mandelbrot of iteratorMandelbrot
--     | Phoenix of iteratorPhoenix
--     | Newton of iteratorNewton
--     | NewtonBOF of iteratorNewtonBOF

data Iterator
    = ItrMandelbrot IteratorMandelbrot
    | ItrPhoenix IteratorPhoenix
    | ItrNewton IteratorNewton
    | ItrNewtonBoF IteratorNewtonBoF
    -- deriving (Show)

-- //master to do list
-- //priority #1
-- //to do:  newton
-- //to do:  abs(magnitude(z) - magnitude(cv)) < epsilon
-- //to do:  interior coloring

-- type xmlIterator = {
--     xml : XElement;
--     iterator : iterator; } with
--     static member create (xml : XElement) =
--         let it = fetchElement xml "iterator"
--         if it <> null then
--             let set = fetchElement it "set"
--             let setName = set.Attribute (xname "type")
--             let set =
--                 match setName with
--                 | null ->
--                     failwith "set type not specified"
--                 | a ->
--                     match a.Value with
--                     | "mandelbrot" ->
--                         iteratedSet.Mandelbrot None
--                     | "julia" ->
--                         let c = set.Attribute (xname "constant")
--                         match c with
--                         | null -> failwith "no constant specified"
--                         | _ ->
--                             let c = schemeParseComplex c.Value
--                             match c with
--                             | Some c ->
--                                 iteratedSet.Julia c
--                             | None ->
--                                 failwith "incorrectly formatted Julia constant"
--                     | _ ->
--                         //to do:  don't hardcode
--                         iteratedSet.NewtonBOF 0.0

xmlSet :: [Cursor] -> Either ScmError IteratedSet
xmlSet cur =
    let attType = Name { nameLocalName = T.pack "type", nameNamespace = Nothing, namePrefix = Nothing }
        elFunction = Name { nameLocalName = T.pack "function", nameNamespace = Nothing, namePrefix = Nothing }
        elSet = Name { nameLocalName = T.pack "set", nameNamespace = Nothing, namePrefix = Nothing }
        attConstant = Name { nameLocalName = T.pack "constant", nameNamespace = Nothing, namePrefix = Nothing }
        itrType = cur >>= C.attribute attType
        itrChild = cur >>= child
        itrFunction = itrChild >>= C.element elFunction
        itrSet = itrChild >>= C.element elSet
        itrSetName = itrSet >>= C.attribute attType
    in
        --to do:  this is the set
        if null itrSetName then --to do:  move this into a function
            Left $ ScmError { errMessage = "x", errCaller = "x" }
        else
            case (head $ map T.unpack itrSetName) of
                "mandelbrot" ->
                    Right $ ItsMandelbrot Nothing
                "julia" ->
                    let const = itrSet >>= C.attribute attConstant
                    in
--                         let c = set.Attribute (xname "constant")
--                         match c with
--                         | null -> failwith "no constant specified"
--                         | _ ->
--                             let c = schemeParseComplex c.Value
--                             match c with
--                             | Some c ->
--                                 iteratedSet.Julia c
--                             | None ->
--                                 failwith "incorrectly formatted Julia constant"
                        undefined
                "newton BOF" ->
                    --ItsNewtonBoF
                    undefined
                otherwise ->
                    undefined

--             let eq = fetchElement it "function"
--             let itType = it.Attribute (xname "type")
--             let fname =
--                 match eq with
--                 | null -> failwith "could not find function specification for iterator"
--                 | _ ->
--                     let fname = eq.Attribute (xname "name")
--                     fname.Value
--             let eq = equationFind fname
--             let eq =
--                 if eq.IsNone then
--                     failwith "bad equation"
--                 else
--                     eq.Value
--             let it =
--                 match itType with
--                 | null -> failwith "unspecified iterator"
--                 | _ ->
--                     match itType.Value, eq with
--                     | "generic", complexEquation.Generic g ->
--                         iterator.Mandelbrot (iteratorMandelbrot.create g set)
--                     | "phoenix", complexEquation.Phoenix p ->
--                         iterator.Phoenix (iteratorPhoenix.create p set)
--                     | "newton BOF", complexEquation.NewtonBOF n ->
--                         iterator.NewtonBOF (iteratorNewtonBOF.create n complexZero)
--                     | "newton", complexEquation.Newton n ->
--                         iterator.Newton (iteratorNewton.create n set)
--                     | _, _ -> failwith "unknown iterator type"
--             {xml = xml; iterator = it}
--         else
--             failwith "bad iterator specified"

xmlIterator :: [Cursor] -> Either ScmError Iterator --should this return an Either?
xmlIterator itr =
    let attType = Name { nameLocalName = T.pack "type", nameNamespace = Nothing, namePrefix = Nothing }
        elFunction = Name { nameLocalName = T.pack "function", nameNamespace = Nothing, namePrefix = Nothing }
        elSet = Name { nameLocalName = T.pack "set", nameNamespace = Nothing, namePrefix = Nothing }
        elConstant = Name { nameLocalName = T.pack "constant", nameNamespace = Nothing, namePrefix = Nothing }
        itrType = itr >>= C.attribute attType
        itrChild = itr >>= child
        itrFunction = itrChild >>= C.element elFunction
        itrSet = xmlSet $ itrChild >>= C.element elSet
        -- itrSetName = itrSet >>= C.attribute attType
    in
        undefined
        --to do:  this is the set
        -- if null itrSetName then --to do:  move this into a function
        --     Left $ ScmError { errMessage = "x", errCaller = "x" }
        -- else
        --     case (head $ map T.unpack itrSetName) of
        --         "mandelbrot" ->
        --             -- ItsMandelbrot
        --             undefined
        --         "julia" ->
        --             --ItsJulia
        --             --to do:  read constant
        --             undefined
        --         "newton BOF" ->
        --             --ItsNewtonBoF
        --             undefined
        --         otherwise ->
        --             undefined

-- type xmlFateCriticalValue = {
--     xml : XElement;
--     criticalValue : iteratedCriticalValue; } with
--     static member fromXML
--         (xml : XElement) (palettes : plotPalettes) (it : iterator) (iterationMax : int) =
--         //critical value
--         let cv = fetchElement xml "value"
--         let cv =
--             match cv with
--             | null -> failwith "no critical value specified"
--             | _ ->
--                 let cv = schemeParseComplex cv.Value
--                 match cv with
--                 | Some cv ->
--                     cv
--                 | None ->
--                     failwith "incorrectly formatted complex number"
--         //iterate the critical value
--         let iteratedCV =
--             match it with
--             | iterator.Mandelbrot m ->
--                 m.init cv
--                 //iterate this iteration times
--                 for i in [0 .. iterationMax - 1] do
--                     m.next ()
--                 m.z
--             | iterator.Phoenix p ->
--                 p.init cv
--                 //iterate this iteration times
--                 for i in [0 .. iterationMax - 1] do
--                     p.next ()
--                 p.z
--             | iterator.NewtonBOF n ->
--                 n.init cv
--                 for i in [0 .. iterationMax - 1] do
--                     n.next ()
--                 n.z
--             | iterator.Newton n ->
--                 n.init cv
--                 for i in [0 .. iterationMax - 1] do
--                     n.next ()
--                 n.z
--         let coloring = fetchElement xml "coloring"
--         let coloring = xmlColoring.fromXML coloring palettes
--         let coloring = coloring.coloring
--         let value =
--             {   criticalValue = cv;
--                 iteratedCriticalValue = iteratedCV.Value;
--                 comparison = (<);
--                 epsilon = Some 0.0003;
--                 coloring = coloring; }
--         {   xml = xml; criticalValue = value; }

-- type iteratedOrbitCheck = {
--     orbitType : orbitPattern;
--     mutable matches : complex list; //to do:  add matches to this list
--     coloring : iteratedFateColoring; } with

--to do:  IteratedOrbitCheck

--     member x.checkFate (it : iterator) (iterationsMax : int) =
--         let iterations, z, orbits =
--             match it with
--             | Newton n ->
--                 n.iterations, n.z, n.orbits
--             | _ ->
--                 failwith "can't check orbits on the given iterator"
--         match x.orbitType with
--         | orbitPattern.Fixpoint ->
--             if orbits.Length >= 2 && z.IsSome && iterations.IsSome then
--                 let t = orbits |> List.tail |> List.head
--                 if z.Value = t then
--                     Some (x.coloring.getColor iterations.Value iterationsMax)
--                 else
--                     None
--             else
--                 None
--         | orbitPattern.Oscillate ->
--             if orbits.Length >= 3 && z.IsSome && iterations.IsSome then
--                 let t = orbits |> List.tail |> List.tail |> List.tryFind (fun x -> x = z.Value)
--                 if t.IsSome then
--                     //to do:  add to matches
--                     Some (x.coloring.getColor iterations.Value iterationsMax)
--                 else
--                     None
--             else
--                 None

--to do:  check fate

-- type xmlFateOrbitCheck = {
--     xml : XElement;
--     orbitChecker : iteratedOrbitCheck; } with
--     static member fromXML
--         (xml : XElement) (palettes : plotPalettes) (it : iterator) =
--         let coloring = fetchElement xml "coloring"
--         let coloring = xmlColoring.fromXML coloring palettes
--         let coloring = coloring.coloring
--         let o = fetchElement xml "value"
--         let orbitCheckType =
--             if o <> null then
--                 match o.Value with
--                 | "fixpoint" ->
--                     Some orbitPattern.Fixpoint
--                 | "oscillation" ->
--                     Some orbitPattern.Oscillate
--                 | _ -> None
--             else
--                 None
--         let oc =
--             if orbitCheckType.IsSome then
--                 { orbitType = orbitCheckType.Value; matches = []; coloring = coloring }
--             else
--                 failwith "bad information for orbit check"
--         { xml = xml; orbitChecker = oc }

-- type fate =
--     | Survivor of xmlFateSurvivor
--     | Escapee of xmlFateEscapee
--     | Fixpoint of xmlFateFixpoint
--     | CriticalValue of xmlFateCriticalValue
--     | OrbitCheck of xmlFateOrbitCheck

--to do:  sum type fate

-- type plotFates = {
--     xml : XElement;
--     iterationMax : int;
--     fates : fate list;
--     } with
--     static member create (xml : XElement) (palettes : plotPalettes) (it : iterator) =
--         let iterations =
--             let at = fetchAttribute xml "iterations"
--             if at.IsNone then
--                 failwith "iteration attribute not found"
--             else
--                 let s, v = Int32.TryParse (at.Value.ToString())
--                 if s then v else failwith "couldn't convert iterations into an int"
--         let fates =
--             xml.Elements ()
--             |> Seq.map
--                 (fun e ->
--                     let name = e.Attribute (xname "type")
--                     let name =
--                         if name = null then
--                             failwith "fate is missing the type attribute"
--                         else
--                             name.Value
--                     match name with
--                     | "survivor" ->
--                         let fateSurvivor = xmlFateSurvivor.fromXML e palettes
--                         fate.Survivor fateSurvivor
--                     | "escapee" ->
--                         let fateEscapee = xmlFateEscapee.fromXML e palettes
--                         fate.Escapee fateEscapee
--                     | "fixpoint" ->
--                         let fateFixpoint = xmlFateFixpoint.fromXML e palettes
--                         fate.Fixpoint fateFixpoint
--                     | "critical value" ->
--                         let fateCriticalValue = xmlFateCriticalValue.fromXML e palettes it iterations
--                         fate.CriticalValue fateCriticalValue
--                     | "orbit check" ->
--                         let fateOrbitCheck = xmlFateOrbitCheck.fromXML e palettes it
--                         fate.OrbitCheck fateOrbitCheck
--                     | _ ->
--                         failwith ("this fate not yet implemented" + name))
--             |> Seq.toList
--         {   xml = xml;
--             iterationMax = iterations;
--             fates = fates; }
--     //to do:  don't pass z, iterations; instead pass iterator
--     member x.checkFates (it : iterator) (z : complex) (iterations : int) (iterationMax : int) =
--         let rec iter lst =
--             match lst with
--             | h::t ->
--                 match h with
--                 | fate.Escapee b ->
--                     let escapee = b.escapee
--                     let color = escapee.checkFate z iterations iterationMax
--                     if color.IsSome then
--                         color
--                     else
--                         iter t
--                 | fate.Fixpoint b ->
--                     let target = b.fixpoint
--                     let color = target.checkFate z iterations iterationMax
--                     if color.IsSome then
--                         color
--                     else
--                         iter t
--                 | fate.CriticalValue b ->
--                     let target = b.criticalValue
--                     let color = target.checkFate z iterations iterationMax
--                     if color.IsSome then
--                         color
--                     else
--                         iter t
--                 | fate.OrbitCheck o ->
--                     let target = o.orbitChecker
--                     let color = target.checkFate it iterationMax
--                     if color.IsSome then
--                         color
--                     else
--                         iter t
--                 | fate.Survivor b ->
--                     let survivor = b.survivor
--                     let color = survivor.checkFate iterations iterationMax
--                     if color.IsSome then
--                         color
--                     else
--                         iter t
--             | [] -> None
--         iter x.fates

-- //to do:  reference xmlInfo and xmlEquation records
-- type complexParameters = {
--     name : string;
--     xml : XElement;
--     }

-- type complexSeed =
--     | Mandelbrot
--     | Julia

-- type bitmap = {
--     width : int;
--     height : int;
--     rawImage : byte[]; } with

--to do

--     static member create w h =
--         let pf = PixelFormats.Bgr32
--         let rawStride = (w * pf.BitsPerPixel + 7) / 8
--         let (max : int) = rawStride * h
--         let (rawImage : byte[]) = Array.zeroCreate max
--         {   width = w;
--             height = h;
--             rawImage = rawImage;  }
--     member t.setPixel (clr : Color) x y =
--         let loc = 4 * (y * t.width + x)
--         t.rawImage.[loc] <- clr.B
--         t.rawImage.[loc + 1] <- clr.G
--         t.rawImage.[loc + 2] <- clr.R
--         ()
--     //to do:  save
--     member t.image () =
--         let pf = PixelFormats.Bgr32
--         let w = t.width
--         let h = t.height
--         let rawStride = (w * pf.BitsPerPixel + 7) / 8
--         let (max : int) = rawStride * h
--         let bitmap = BitmapSource.Create (w, h, 96.0, 96.0, pf, null, t.rawImage, rawStride)
--         //let bitmap = BitmapSource.Create (w, h, 300.0, 300.0, pf, null, t.rawImage, rawStride)
--         let img = new Image()
--         img.Width <- float t.width
--         img.Height <- float t.height
--         img.Source <- bitmap
--         img

-- //to do:  bitmap record
-- //bresenham algorithm

-- //to do:  need info record
-- type plotObject = {
--     xml : XElement;
--     coords : plotCoordinates;
--     palettes : plotPalettes;
--     fates : plotFates;
--     iterator : xmlIterator;
--     bitmap : bitmap; } with
--     static member create (xml : XElement) =
--         let coords = xml.Element(xname "coordinates")
--         let recCoordinates = plotCoordinates.create coords
--         let palettes = xml.Element (xname "palettes")
--         let plotPalettes = plotPalettes.create palettes
--         let fates = xml.Element (xname "fates")
--         let width = recCoordinates.coords.width
--         let height = recCoordinates.coords.height
--         let bitmap = bitmap.create width height
--         let iterator = xmlIterator.create xml
--         let plotFates = plotFates.create fates plotPalettes iterator.iterator
--         {   xml = xml;
--             coords = recCoordinates;
--             palettes = plotPalettes;
--             fates = plotFates;
--             iterator = iterator;
--             bitmap = bitmap; }
--     member x.iterate z =
--         let it = x.iterator.iterator
--         match it with
--         | iterator.Mandelbrot i ->
--             i.init z
--         | iterator.Phoenix p ->
--             p.init z
--         | iterator.NewtonBOF n ->
--             n.init z
--         | iterator.Newton n ->
--             n.init z
--         let iterationMax = x.fates.iterationMax
--         let rec iter () =
--             let iterations =
--                 match it with
--                 | iterator.Mandelbrot m -> m.iterations
--                 | iterator.Phoenix p -> p.iterations
--                 | iterator.NewtonBOF n -> n.iterations
--                 | iterator.Newton n -> n.iterations
--             let iterations =
--                 match iterations with
--                 | Some i -> i
--                 | None -> failwith "bad value for iterations"
--             let z =
--                 match it with
--                 | iterator.Mandelbrot m ->
--                     match m.z with
--                     | Some z -> z
--                     | None -> failwith "bad value of z"
--                 | iterator.Phoenix p ->
--                     match p.z with
--                     | Some z -> z
--                     | None -> failwith "bad value of z"
--                 | iterator.NewtonBOF n ->
--                     match n.z with
--                     | Some z -> z
--                     | None -> failwith "bad value of z"
--                 | iterator.Newton n ->
--                     match n.z with
--                     | Some z -> z
--                     | None -> failwith "bad value of z"
--             let color = x.fates.checkFates it z iterations iterationMax
--             match color with
--             | Some c ->
--                 c
--             | None ->
--                 match it with
--                 | iterator.Mandelbrot m -> m.next ()
--                 | iterator.Phoenix p -> p.next ()
--                 | iterator.NewtonBOF n -> n.next ()
--                 | iterator.Newton n -> n.next ()
--                 iter ()
--         iter ()
--     member x.plot () =
--         let pixelsY = x.coords.coords.pixelDistanceY
--         let pixelsX = x.coords.coords.pixelDistanceX
--         let yMax = x.coords.coords.maxY
--         let xMin = x.coords.coords.minX
--         let upp = x.coords.coords.upp
--         let mutable yCoordinate = 0.0 * 1.0<pixels>
--         let switchXY =
--             match x.coords.swapXY with
--             | Some b -> b
--             | None -> false
--         while yCoordinate <= pixelsY do
--             let yUnit = yMax - (yCoordinate * upp)
--             let mutable xCoordinate = 0.0 * 1.0<pixels>
--             while xCoordinate <= pixelsX do
--                 let xUnit = xMin + (xCoordinate * upp)
--                 let z =
--                     if switchXY then
--                         complex (float yUnit) (float xUnit)
--                     else
--                         complex (float xUnit) (float yUnit)
--                 let color = x.iterate z
--                 let xInt = int (float xCoordinate)
--                 let yInt = int (float yCoordinate)
--                 x.bitmap.setPixel color xInt yInt
--                 xCoordinate <- xCoordinate + 1.0<pixels>
--             yCoordinate <- yCoordinate + 1.0<pixels>
--         x.bitmap

data XmlComplex = XmlComplex
    { xcmName :: String
    , xcmDesc :: String
    -- , xcmIterator :: String --to do:  sum type for iterator types
    -- , xobGenerations :: Int
    -- , xobLength :: Double
    -- , xobRules :: String
    -- , xobBuiltIn :: Bool
    -- , xobContinuous :: Bool
    -- , xobColors :: [Color]
    -- , xobAlgorithm :: ColoringAlgorithm
    } deriving (Eq, Show)

ctorXmlComplex :: [Cursor] -> XmlComplex
ctorXmlComplex el =
    let
        info = Name { nameLocalName = T.pack "info", nameNamespace = Nothing, namePrefix = Nothing }
        nm = Name { nameLocalName = T.pack "name", nameNamespace = Nothing, namePrefix = Nothing }
        desc = Name { nameLocalName = T.pack "description", nameNamespace = Nothing, namePrefix = Nothing }
        iterator = Name { nameLocalName = T.pack "iterator", nameNamespace = Nothing, namePrefix = Nothing }
        coordinates = Name { nameLocalName = T.pack "coordinates", nameNamespace = Nothing, namePrefix = Nothing }
        palettes = Name { nameLocalName = T.pack "palettes", nameNamespace = Nothing, namePrefix = Nothing }
        fates = Name { nameLocalName = T.pack "fates", nameNamespace = Nothing, namePrefix = Nothing }
--         params = Name { nameLocalName = T.pack "parameters", nameNamespace = Nothing, namePrefix = Nothing }
--         rules = Name { nameLocalName = T.pack "rules", nameNamespace = Nothing, namePrefix = Nothing }
--         gen = Name { nameLocalName = T.pack "generations", nameNamespace = Nothing, namePrefix = Nothing }
--         len = Name { nameLocalName = T.pack "length", nameNamespace = Nothing, namePrefix = Nothing }
--         coloring = Name { nameLocalName = T.pack "coloring", nameNamespace = Nothing, namePrefix = Nothing }
--         typeAtt = Name { nameLocalName = T.pack "type", nameNamespace = Nothing, namePrefix = Nothing }
--         palette = Name { nameLocalName = T.pack "palette", nameNamespace = Nothing, namePrefix = Nothing }
--         color = Name { nameLocalName = T.pack "color", nameNamespace = Nothing, namePrefix = Nothing }
--         algorithm = Name { nameLocalName = T.pack "algorithm", nameNamespace = Nothing, namePrefix = Nothing }
--         continuous = Name { nameLocalName = T.pack "continuous", nameNamespace = Nothing, namePrefix = Nothing }
        complex1descendants = el >>= descendant
        info1 = complex1descendants >>= C.element info >>= child
        name1 = info1 >>= C.element nm >>= child >>= content
        fractalName = if null name1 then "" else head $ map T.unpack name1
        desc1 = info1 >>= C.element desc >>= child >>= content
        description = if null desc1 then "" else head $ map T.unpack desc1
        iterator1 = complex1descendants >>= C.element iterator >>= child
        coordinates1 = complex1descendants >>= C.element coordinates >>= child
        palettes1 = complex1descendants >>= C.element palettes >>= child
        fates1 = complex1descendants >>= C.element fates >>= child
--         params1 = vec1desc >>= C.element params >>= child
--         rules1 = vec1desc >>= C.element rules
--         rulesType1 = rules1 >>= C.attribute typeAtt
--         rules1Continuous = rules1 >>= C.attribute continuous
--         rulesContent1 = rules1 >>= child >>= content
--         rulesValue = if null rulesContent1 then "" else head $ map T.unpack rulesContent1
--         gen1 = params1 >>= C.element gen >>= child >>= content
--         genMaybe = readMaybe (head $ map T.unpack gen1) :: Maybe Int
--         generations = maybe 1 id genMaybe
--         len1 = params1 >>= C.element len >>= child >>= content
--         lenMaybe = readMaybe (head $ map T.unpack len1) :: Maybe Double
--         length = maybe 1.0 id lenMaybe
--         coloring1 = params1 >>= C.element coloring >>= child
--         palette1 = coloring1 >>= C.element palette >>= child
--         color1 = palette1 >>= C.element color >>= child
--         colorName1 = color1 >>= C.element nm >>= child >>= content
--         algorithm1 = coloring1 >>= C.element algorithm
--         algType = algorithm1 >>= C.attribute typeAtt
--         algUnpacked = map T.unpack algType
--         alg = if null algUnpacked then "level" else head algUnpacked
--         cont =
--             if null rules1Continuous then
--                 True
--             else
--                 "yes" == (head $ map T.unpack rules1Continuous)
--         builtin =
--             if null rulesType1 then
--                 True
--             else
--                 "builtin" == (head $ map T.unpack rulesType1)
--         colorAlg = ctorColoringAlgorithm alg algorithm1
    in
        XmlComplex
            { xcmName = fractalName
            , xcmDesc = description
            -- , xobGenerations = generations
            -- , xobLength = length
            -- , xobRules = rulesValue
            -- , xobBuiltIn = builtin
            -- , xobColors = map T.unpack colorName1
            -- , xobAlgorithm = maybe (CalLevel 1) id colorAlg
            -- , xobContinuous = cont
            }

parseXmlComplex :: String -> IO [XmlComplex]
parseXmlComplex fname = do
    doc <- readFile def fname
    let cursor = fromDocument doc
        complex = Name { nameLocalName = T.pack "complex", nameNamespace = Nothing, namePrefix = Nothing }
        vecs = child cursor >>= C.element complex
        plotObjects = map (\x -> ctorXmlComplex [x]) vecs
        po1 = head plotObjects
    return plotObjects

-- let populateCbx (cbx : ComboBox) (xmlFolder : string) =
--     cbx.DisplayMemberPath <- "name"
--     let xml = XDocument.Load(xmlFolder + @"\complex.xml")
--     let xname n = XName.op_Implicit(n)
--     let plots = xml.Element(xname "plots")
--     let xelem s el = new XElement(xname s, box el)
--     let xatt a b = new XAttribute(xname a, b) |> box
--     let xstr s = box s
--     //walk through xml elements and create records
--     for elem in plots.Elements() do
--         //to do:  use xmlInfo and xmlEquation records
--         let info = elem.Element (xname "info")
--         let it = elem.Element (xname "iterator")
--         let eqName, setName, fName =
--             let functionNode = fetchElement it "function"
--             let eqName = functionNode.Attribute (xname "name")
--             let eqName = eqName.Value
--             let fName = fetchElement info "name"
--             let fName = fName.Value
--             let setNode = fetchElement it "set"
--             let setName = setNode.Attribute (xname "type")
--             let setName = setName.Value
--             eqName, setName, fName
--         let (param : complexParameters) = {
--             name = "[" + eqName + "/" + setName + "] " + fName;
--             xml = elem;
--             }
--         cbx.Items.Add(param) |> ignore


{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.Internal.Pooling where

import           Grenade.Layers.Internal.Pooling

import           Control.Monad

import           Numeric.LinearAlgebra                  hiding (konst,
                                                         uniformSample, (===))

import           Hedgehog
import qualified Hedgehog.Gen                           as Gen
import qualified Hedgehog.Range                         as Range

import qualified Test.Grenade.Layers.Internal.Reference as Reference
import           Test.Hedgehog.Compat

import           Grenade.Types

prop_poolForwards_poolBackwards_behaves_as_reference =
  let ok extent kernel = [stride | stride <- [1..extent], (extent - kernel) `mod` stride == 0]
      output extent kernel stride = (extent - kernel) `div` stride + 1
  in  property $ do
        height   <- forAll $ choose 2 100
        width    <- forAll $ choose 2 100
        kernel_h <- forAll $ choose 1 (height - 1)
        kernel_w <- forAll $ choose 1 (width - 1)
        stride_h <- forAll $ Gen.element (ok height kernel_h)
        stride_w <- forAll $ Gen.element (ok width kernel_w)
        input    <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

        let outFast       = poolForward 1 height width kernel_h kernel_w stride_h stride_w input
        let retFast       = poolBackward 1 height width kernel_h kernel_w stride_h stride_w input outFast

        let outReference  = Reference.poolForward kernel_h kernel_w stride_h stride_w (output height kernel_h stride_h) (output width kernel_w stride_w) input
        let retReference  = Reference.poolBackward kernel_h kernel_w stride_h stride_w  input outReference

        outFast === outReference
        retFast === retReference

prop_same_pad_pool_behaves_as_reference_when_zero_pad =
  let output extent kernel_dim stride = (extent - kernel_dim) `div` stride + 1
      kernel i s = let x = ceiling ((fromIntegral i :: RealNum) / (fromIntegral s :: RealNum)) in i - (x - 1) * s
  in  property $ do
        height   <- forAll $ choose 2 100
        width    <- forAll $ choose 2 100

        stride_h <- forAll $ choose 1 (height - 1)
        stride_w <- forAll $ choose 1 (width - 1)

        let kernel_h = kernel height stride_h
            kernel_w = kernel width stride_w

        input    <- forAll $ (height >< width) <$> Gen.list (Range.singleton $ height * width) (Gen.realFloat $ Range.linearFracFrom 0 (-100) 100)

        guard $ output height kernel_h stride_h == (ceiling $ (fromIntegral height :: RealNum) / (fromIntegral stride_h :: RealNum))
        guard $ output width kernel_w stride_w  == (ceiling $ (fromIntegral width :: RealNum)  / (fromIntegral stride_w :: RealNum))

        let outFast       = validPadPoolForwards 1 height width kernel_h kernel_w stride_h stride_w 0 0 0 0 input
        let outReference  = poolForward 1 height width kernel_h kernel_w stride_h stride_w input

        assert $ norm_Inf (outFast - outReference) < 0.000001

prop_same_pad_pool_behaves_correctly_at_edges = withTests 1 $ property $ do
  let input           = (2 >< 2) [-0.01, -0.04, -0.02, -0.03]
      expected_output = (2 >< 2) [-0.01, -0.03, -0.02, -0.03]

      out = validPadPoolForwards 1 2 2 2 2 1 1 0 0 1 1 input

  assert $ norm_Inf (out - expected_output) < 0.000001

prop_same_pad_pool_behaves_correctly_at_edges_three_channels = withTests 1 $ property $ do
  let input           = (6 >< 2) [ 0.7, -0.9, -1.4, -0.1, -0.3, 0.5, 0.1, 0.2, -1.1, -0.7, 0.5, -0.7]
      expected_output = (6 >< 2) [ 0.7, -0.1, -0.1, -0.1, 0.5, 0.5, 0.2, 0.2, 0.5, -0.7, 0.5, -0.7]

      out = validPadPoolForwards 3 2 2 2 2 1 1 0 0 1 1 input

  assert $ norm_Inf (out - expected_output) < 0.000001

tests :: IO Bool
tests = checkParallel $$(discover)


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

-----------------------------------------------------------------------------
{- |
Module      :  Numeric.LinearAlgebra
Copyright   :  (c) Alberto Ruiz 2006-15
License     :  BSD3
Maintainer  :  Alberto Ruiz
Stability   :  provisional

-}
-----------------------------------------------------------------------------
module Numeric.LinearAlgebra (

    -- * Basic types and data manipulation
    -- | This package works with 2D ('Matrix') and 1D ('Vector')
    -- arrays of real ('R') or complex ('C') double precision numbers.
    -- Single precision and machine integers are also supported for
    -- basic arithmetic and data manipulation.
    module Numeric.LinearAlgebra.Data,

    -- * Numeric classes
    -- |
    -- The standard numeric classes are defined elementwise (commonly referred to
    -- as the Hadamard product or the Schur product):
    --
    -- >>>  vector [1,2,3] * vector [3,0,-2]
    -- [3.0,0.0,-6.0]
    -- it :: Vector R
    --
    -- >>> matrix 3 [1..9] * ident 3
    -- (3><3)
    --  [ 1.0, 0.0, 0.0
    --  , 0.0, 5.0, 0.0
    --  , 0.0, 0.0, 9.0 ]

    -- * Autoconformable dimensions
    -- |
    -- In most operations, single-element vectors and matrices
    -- (created from numeric literals or using 'scalar'), and matrices
    -- with just one row or column, automatically
    -- expand to match the dimensions of the other operand:
    --
    -- >>> 5 + 2*ident 3 :: Matrix Double
    -- (3><3)
    --  [ 7.0, 5.0, 5.0
    --  , 5.0, 7.0, 5.0
    --  , 5.0, 5.0, 7.0 ]
    --
    -- >>> (4><3) [1..] + row [10,20,30]
    -- (4><3)
    --  [ 11.0, 22.0, 33.0
    --  , 14.0, 25.0, 36.0
    --  , 17.0, 28.0, 39.0
    --  , 20.0, 31.0, 42.0 ]
    --

    -- * Products
    -- ** Dot
    dot, (<.>),
    -- ** Matrix-vector
    (#>), (<#), (!#>),
    -- ** Matrix-matrix
    (<>),
    -- | The matrix product is also implemented in the "Data.Monoid" instance, where
    -- single-element matrices (created from numeric literals or using 'scalar')
    -- are used for scaling.
    --
    -- >>> import Data.Monoid as M
    -- >>>  let m = matrix 3 [1..6]
    -- >>> m M.<> 2 M.<> diagl[0.5,1,0]
    -- (2><3)
    --  [ 1.0,  4.0, 0.0
    --  , 4.0, 10.0, 0.0 ]
    --
    -- 'mconcat' uses 'optimiseMult' to get the optimal association order.

    -- ** Other
    outer, kronecker, cross,
    scale, add,
    sumElements, prodElements,

    -- * Linear systems
    -- ** General
    (<\>),
    linearSolveLS,
    linearSolveSVD,
    -- ** Determined
    linearSolve,
    luSolve, luPacked,
    luSolve', luPacked',
    -- ** Symmetric indefinite
    ldlSolve, ldlPacked,
    -- ** Positive definite
    cholSolve,
    -- ** Triangular
    UpLo(..),
    triSolve,
    -- ** Tridiagonal
    triDiagSolve,
    -- ** Sparse
    cgSolve,
    cgSolve',

    -- * Inverse and pseudoinverse
    inv, pinv, pinvTol,

    -- * Determinant and rank
    rcond, rank,
    det, invlndet,

    -- * Norms
    Normed(..),
    norm_Frob, norm_nuclear,

    -- * Nullspace and range
    orth,
    nullspace, null1, null1sym,

    -- * Singular value decomposition
    svd,
    thinSVD,
    compactSVD,
    compactSVDTol,
    singularValues,
    leftSV, rightSV,

    -- * Eigendecomposition
    eig, geig, eigSH,
    eigenvalues, geigenvalues, eigenvaluesSH,
    geigSH,

    -- * QR
    qr, thinQR, rq, thinRQ, qrRaw, qrgr,

    -- * Cholesky
    chol, mbChol,

    -- * LU
    lu, luFact,

    -- * Hessenberg
    hess,

    -- * Schur
    schur,

    -- * Matrix functions
    expm,
    sqrtm,
    matFunc,

    -- * Correlation and convolution
    corr, conv, corrMin, corr2, conv2,

    -- * Random arrays

    Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample,

    -- * Misc
    meanCov, rowOuters, pairwiseD2, normalize, peps, relativeError, magnit,
    haussholder, optimiseMult, udot, nullspaceSVD, orthSVD, ranksv,
    iC, sym, mTm, trustSym, unSym,
    -- * Auxiliary classes
    Element, Container, Product, Numeric, LSDiv, Herm,
    Complexable, RealElement,
    RealOf, ComplexOf, SingleOf, DoubleOf,
    IndexOf,
    Field, Linear(), Additive(),
    Transposable,
    LU(..),
    LDL(..),
    QR(..),
    CGState(..),
    Testable(..)
) where

import Numeric.LinearAlgebra.Data

import Numeric.Matrix()
import Numeric.Vector()
import Internal.Matrix
import Internal.Container hiding ((<>))
import Internal.Numeric hiding (mul)
import Internal.Algorithms hiding (linearSolve,Normed,orth,luPacked',linearSolve',luSolve',ldlPacked')
import qualified Internal.Algorithms as A
import Internal.Util
import Internal.Random
import Internal.Sparse((!#>))
import Internal.CG
import Internal.Conversion
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

{- | dense matrix product

>>> let a = (3><5) [1..]
>>> a
(3><5)
 [  1.0,  2.0,  3.0,  4.0,  5.0
 ,  6.0,  7.0,  8.0,  9.0, 10.0
 , 11.0, 12.0, 13.0, 14.0, 15.0 ]

>>> let b = (5><2) [1,3, 0,2, -1,5, 7,7, 6,0]
>>> b
(5><2)
 [  1.0, 3.0
 ,  0.0, 2.0
 , -1.0, 5.0
 ,  7.0, 7.0
 ,  6.0, 0.0 ]

>>> a <> b
(3><2)
 [  56.0,  50.0
 , 121.0, 135.0
 , 186.0, 220.0 ]

-}
(<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t
(<>) = mXm
infixr 8 <>

{- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.

@
a = (2><2)
 [ 1.0, 2.0
 , 3.0, 5.0 ]
@

@
b = (2><3)
 [  6.0, 1.0, 10.0
 , 15.0, 3.0, 26.0 ]
@

>>> linearSolve a b
Just (2><3)
 [ -1.4802973661668753e-15,     0.9999999999999997, 1.999999999999997
 ,       3.000000000000001, 1.6653345369377348e-16, 4.000000000000002 ]

>>> let Just x = it
>>> disp 5 x
2x3
-0.00000  1.00000  2.00000
 3.00000  0.00000  4.00000

>>> a <> x
(2><3)
 [  6.0, 1.0, 10.0
 , 15.0, 3.0, 26.0 ]

-}
linearSolve m b = A.mbLinearSolve m b

-- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'.
nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m)

-- | return an orthonormal basis of the range space of a matrix. See also 'orthSVD'.
orth m = orthSVD (Left (1*eps)) m (leftSV m)


{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Foreign.VMath.VFloating
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Vector Floating operations.
--

module Foreign.VMath.VFloating (
    VFloating(..)
    ) where

import Foreign( Ptr, Storable, peek, poke, advancePtr )
import Data.Complex( Complex(..) )

import Foreign.VMath.VFractional
import Foreign.VMath.Double
import Foreign.VMath.Zomplex

-- | Types with vectorized 'Floating' operations.
class (VFractional a, Floating a) => VFloating a where
    vExp :: Int -> Ptr a -> Ptr a -> IO ()
    vSqrt :: Int -> Ptr a -> Ptr a -> IO ()
    vLog :: Int -> Ptr a -> Ptr a -> IO ()
    vPow :: Int -> Ptr a -> Ptr a -> Ptr a -> IO ()
    vSin :: Int -> Ptr a -> Ptr a -> IO ()
    vCos :: Int -> Ptr a -> Ptr a -> IO ()
    vTan :: Int -> Ptr a -> Ptr a -> IO ()
    vASin :: Int -> Ptr a -> Ptr a -> IO ()
    vACos :: Int -> Ptr a -> Ptr a -> IO ()
    vATan :: Int -> Ptr a -> Ptr a -> IO ()
    vSinh :: Int -> Ptr a -> Ptr a -> IO ()
    vCosh :: Int -> Ptr a -> Ptr a -> IO ()
    vTanh :: Int -> Ptr a -> Ptr a -> IO ()
    vASinh :: Int -> Ptr a -> Ptr a -> IO ()
    vACosh :: Int -> Ptr a -> Ptr a -> IO ()
    vATanh :: Int -> Ptr a -> Ptr a -> IO ()

    vExp = vop exp
    vSqrt = vop sqrt
    vLog = vop log
    vPow = vop2 (**)
    vSin = vop sin
    vCos = vop cos
    vTan = vop tan
    vASin = vop asin
    vACos = vop acos
    vATan = vop atan
    vSinh = vop sinh
    vCosh = vop cosh
    vTanh = vop tanh
    vASinh = vop asinh
    vACosh = vop acosh
    vATanh = vop atanh

vop :: (Storable a, Storable b)
    => (a -> b) -> Int -> Ptr a -> Ptr b -> IO ()
vop f n src dst | n <= 0    = return ()
                | otherwise = do
    a <- peek src
    poke dst $ f a
    vop f (n-1) (src `advancePtr` 1) (dst `advancePtr` 1)
{-# INLINE vop #-}

vop2 :: (Storable a1, Storable a2, Storable b)
     => (a1 -> a2 -> b) -> Int -> Ptr a1 -> Ptr a2 -> Ptr b -> IO ()
vop2 f n src1 src2 dst | n <= 0    = return ()
                       | otherwise = do
    a1 <- peek src1
    a2 <- peek src2
    poke dst $ f a1 a2
    vop2 f (n-1) (src1 `advancePtr` 1) (src2 `advancePtr` 1)
         (dst `advancePtr` 1)
{-# INLINE vop2 #-}

instance VFloating Double where
    vExp = vdExp
    {-# INLINE vExp #-}
    vSqrt = vdSqrt
    {-# INLINE vSqrt #-}
    vLog = vdLog
    {-# INLINE vLog #-}
    vPow = vdPow
    {-# INLINE vPow #-}
    vSin = vdSin
    {-# INLINE vSin #-}
    vCos = vdCos
    {-# INLINE vCos #-}
    vTan = vdTan
    {-# INLINE vTan #-}
    vASin = vdASin
    {-# INLINE vASin #-}
    vACos = vdACos
    {-# INLINE vACos #-}
    vATan = vdATan
    {-# INLINE vATan #-}
    vSinh = vdSinh
    {-# INLINE vSinh #-}
    vCosh = vdCosh
    {-# INLINE vCosh #-}
    vTanh = vdTanh
    {-# INLINE vTanh #-}
    vASinh = vdASinh
    {-# INLINE vASinh #-}
    vACosh = vdACosh
    {-# INLINE vACosh #-}
    vATanh = vdATanh
    {-# INLINE vATanh #-}

instance VFloating (Complex Double) where
    vSqrt = vzSqrt
    {-# INLINE vSqrt #-}
    vLog = vzLog
    {-# INLINE vLog #-}

    {- These functions have branch cuts in the wrong places
    vExp = vzExp
    {-# INLINE vExp #-}
    vPow = vzPow
    {-# INLINE vPow #-}
    vSin = vzSin
    {-# INLINE vSin #-}
    vCos = vzCos
    {-# INLINE vCos #-}
    vTan = vzTan
    {-# INLINE vTan #-}
    vASin = vzASin
    {-# INLINE vASin #-}
    vACos = vzACos
    {-# INLINE vACos #-}
    vATan = vzATan
    {-# INLINE vATan #-}
    vSinh = vzSinh
    {-# INLINE vSinh #-}
    vCosh = vzCosh
    {-# INLINE vCosh #-}
    vTanh = vzTanh
    {-# INLINE vTanh #-}
    vASinh = vzASinh
    {-# INLINE vASinh #-}
    vACosh = vzACosh
    {-# INLINE vACosh #-}
    vATanh = vzATanh
    {-# INLINE vATanh #-}
    -}


module Parser (
  readExpr
              )
  where

import Text.ParserCombinators.Parsec hiding (spaces)
import System.Environment
import Control.Monad
import Numeric (readOct, readHex, readFloat)
import Data.Char (digitToInt)
import Data.Ratio ((%), Rational)
import Data.Complex (Complex (..))

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | Integer Integer
             | String String
             | Bool Bool
             | Ratio Rational
             | Complex (Complex Float)
             | Float Float
             | Character Char
  deriving (Eq, Show)

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

myEscapes :: Parser Char
myEscapes = do
  char '\\'
  char_escaped <- oneOf ['"', 'n', 't', 'r', '\\']
  return $ case char_escaped of
    '\\' -> '\\'
    '"'  -> '"'
    'n'  -> '\n'
    'r'  -> '\r'
    't'  -> '\t'

-- test escaping quotes with: "\"\\\"\"" hahaha
parseString :: Parser LispVal
parseString = do
  char '"'
  x <- many (myEscapes <|> noneOf ['\\', '"'])
  char '"'
  return $ String x

parseAtom :: Parser LispVal
parseAtom = do
  first <- letter <|> symbol
  rest <- many (letter <|> digit <|> symbol)
  let atom = first:rest
  return $ case atom of
    "#t" -> Bool True
    "#f" -> Bool False
    _    -> Atom atom

parseDecimal :: Parser LispVal
parseDecimal = liftM (Integer . read) $ many1 digit

readBinRec :: [Int] -> Integer
readBinRec (lsb : rest) = (toInteger lsb) + 2 * readBinRec rest
readBinRec [] = 0

readBinReal :: String -> Integer
readBinReal = readBinRec . reverse . map digitToInt

parseBinary :: Parser LispVal
parseBinary = liftM (Integer. readBinReal) $ many1 (oneOf "01")

readOctReal :: String -> Integer
readOctReal s = fst ((readOct s) !! 0)
parseOctal :: Parser LispVal
parseOctal = liftM (Integer . readOctReal) $ many1 (oneOf "01234567")

readHexReal :: String -> Integer
readHexReal s = fst ((readHex s) !! 0)
parseHex :: Parser LispVal
parseHex = liftM (Integer . readHexReal) $ many1 (oneOf "0123456789ABCDEFabcdef")

parsePrefixedNumber :: Parser LispVal
parsePrefixedNumber = do
  char '#'
  radix <- oneOf ['b', 'o', 'd', 'x']
  case radix of
    'b' -> parseBinary
    'o' -> parseOctal
    'd' -> parseDecimal
    'x' -> parseHex

parseFloat :: Parser LispVal
parseFloat = do
  whole_num <- many1 digit
  char '.'
  fractional_bit <- many1 digit
  return . Float . fst $ (readFloat (whole_num ++ "." ++ fractional_bit) !! 0 )

parseRational :: Parser LispVal
parseRational = do
  top <- many1 digit
  char '/'
  bottom <- many1 digit
  return $ Ratio (read top % read bottom)

floatCast :: LispVal -> Float
floatCast (Float f) = f
floatCast (Integer i) = fromIntegral i

parseComplex :: Parser LispVal
parseComplex = do
  first_bit <- try parseFloat <|> parseDecimal
  char '+'
  second_bit <- try parseFloat <|> parseDecimal
  char 'i'
  (return . Complex) ((floatCast first_bit) :+ (floatCast second_bit))

-- #b (binary), #o (octal), #d (decimal), and #x (hexadecimal)
parseNumber :: Parser LispVal
parseNumber =
  try parseRational
  <|> try parseComplex
  <|> try parseFloat
  <|> try parsePrefixedNumber
  <|> parseDecimal

{-
parseNumber' :: Parser LispVal
parseNumber' = do
  digits <- many1 digit
  return ((Number . read) digits)

parseNumber'' :: Parser LispVal
parseNumber'' = many1 digit >>= (return . Number . read)
-}

{-Characters are objects that represent printed characters such as letters and digits. Characters are written using the notation #\<character> or #\<character name>. For example:

#\a	; lower case letter
#\A	; upper case letter
#\(	; left parenthesis
#\	; the space character
#\space	; the preferred way to write a space
#\newline	; the newline character
Case is significant in #\<character>, but not in #\<character name>. If <character> in #\<character> is alphabetic, then the character following <character> must be a delimiter character such as a space or parenthesis. This rule resolves the ambiguous case where, for example, the sequence of characters ``#\space'' could be taken to be either a representation of the space character or a representation of the character ``#\s'' followed by a representation of the symbol ``pace.''

Characters written in the #\ notation are self-evaluating. That is, they do not have to be quoted in programs. Some of the procedures that operate on characters ignore the difference between upper case and lower case. The procedures that ignore case have ``-ci'' (for ``case insensitive'') embedded in their names.
-}
parseChar :: Parser LispVal
parseChar = do
  char '#' >> char '\\'
  rest <- (string "space") <|> (string "newline") <|> (anyChar >>= (\x -> return  [x]))
  return (Character $ case rest of
    "space" -> ' '
    "newline" -> '\n'
    c -> c !! 0)

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

parseDottedList :: Parser LispVal
parseDottedList = do
    head <- endBy parseExpr spaces
    tail <- char '.' >> spaces >> parseExpr
    return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

{-parseQuasiQuoted :: Parser LispVal
parseQuasiQuoted = do
    char '`'
    x <- parseExpr
    return $ List [Atom "quote", x]-}
parseExpr :: Parser LispVal
parseExpr = try parseAtom
         <|> try parseChar
         <|> try parseNumber
         <|> try parseString
         <|> try parseQuoted
         <|> do char '('
                x <- try parseList <|> parseDottedList
                char ')'
                return x

readExpr :: String -> String
readExpr input = case parse parseExpr "lisp" input of
    Left err -> "No match: " ++ show err ++ ", input: " ++ input
    Right val -> "Found value: " ++ show val


{-# LANGUAGE FlexibleContexts #-}
module DFTPinwheel where

import           Control.Monad                  as M
import qualified Data.Array.Accelerate          as A
import           Data.Array.Accelerate.LLVM.PTX
import           Data.Array.Repa                as R
import           Data.Complex
import           Data.List                      as L
import           Data.Vector.Storable           as VS
import           Data.Vector.Unboxed            as VU
import           DFT.Plan
import           Filter.Utils
import           Foreign.CUDA.Driver            as CUDA
import           FourierMethod.BlockCudaMatrix
import           FourierMethod.FourierSeries2D
import           Image.IO
import           Pinwheel.Base
import           Pinwheel.FourierSeries2D
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.Random
import           Utils.SimpsonRule
import Utils.Array
import Numeric.GSL.Special.Bessel
import           Utils.Distribution

main = do
  args@(deviceIDsStr:numPointsStr:numR2FreqStr:deltaStr:deltaReconStr:periodR2Str:angularFreqStr:radialFreqStr:sigmaStr:periodEnvelopeStr:stdStr:numBatchStr:_) <-
    getArgs
  let deviceIDs = read deviceIDsStr :: [Int]
      numPoints = read numPointsStr :: Int
      numR2Freqs = read numR2FreqStr :: Int
      delta = read deltaStr :: Double
      deltaRecon = read deltaReconStr :: Double
      periodR2 = read periodR2Str :: Double
      angularFreq = read angularFreqStr :: Int
      radialFreq = read radialFreqStr :: Int
      sigma = read sigmaStr :: Double
      periodEnvelope = read periodEnvelopeStr :: Double
      std = read stdStr :: Double
      numBatch = read numBatchStr :: Int
      folderPath = "output/test/DFTPinwheel"
  removePathForcibly folderPath
  createDirectoryIfMissing True folderPath
  initialise []
  devs <- M.mapM device deviceIDs
  ctxs <- M.mapM (\dev -> CUDA.create dev []) devs
  ptxs <- M.mapM createTargetFromContext ctxs
  let center = div numPoints 2
      pinwheel =
        computeUnboxedS . R.fromFunction (Z :. numPoints :. numPoints) $ \(Z :. x :. y) ->
          fourierMellinInvPeriod
            sigma
            (periodEnvelope * sqrt 2)
            angularFreq
            radialFreq
            ( deltaRecon * fromIntegral (x - center)
            , deltaRecon * fromIntegral (y - center))
      pinwheelMat =
        CuMat (numPoints ^ 2) 1 . CuVecHost . VU.convert . toUnboxed $ pinwheel
      centerFreq = div numR2Freqs 2
      -- pinwheelFreq =
      --   computeUnboxedS . R.fromFunction (Z :. numR2Freqs :. numR2Freqs) $ \(Z :. x :. y) ->
      --     fourierMellin
      --       sigma
      --       angularFreq
      --       radialFreq
      --       ( delta * fromIntegral (x - centerFreq)
      --       , delta * fromIntegral (y - centerFreq))
      -- pinwheelFreqMat =
      --   CuMat 1 (numR2Freqs ^ 2) . CuVecHost . VU.convert . toUnboxed $ -- . computeS . weightedArray
      --   pinwheelFreq
  -- invHarmonics <-
  --   createInverseHarmonicMatriesGPU ptxs 1 numPoints numR2Freqs periodR2 delta
  -- pinwheelCoef <-
  --   computeFourierCoefficientsR2Stream
  --     deviceIDs
  --     ptxs
  --     numR2Freqs
  --     numPoints
  --     periodR2
  --     delta
  --     1
  --     numBatch
  --     [pinwheelMat]
  -- pinwheelFreqSeries <-
  --   computeFourierSeriesR2
  --     deviceIDs
  --     numR2Freqs
  --     numPoints
  --     periodR2
  --     invHarmonics
  --     [pinwheelFreqMat]
  plotImageRepaComplex (folderPath </> "Pinwheel.png") .
    ImageRepa 8 .
    computeS . extend (Z :. (1 :: Int) :. All :. All) . R.traverse pinwheel id $ \f idx@(Z :. i :. j) ->
    let x = fromIntegral $ i - center
        y = fromIntegral $ j - center
        r = sqrt $ x ^ 2 + y ^ 2
       -- if r <= 6
       --   then 0
       --   else
     in f idx
  -- plotImageRepaComplex (folderPath </> "PinwheelTest.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelTest
  -- plotImageRepaComplex (folderPath </> "PinwheelCoefficients.png") .
  --   ImageRepa 8 . computeS . R.traverse pinwheelCoef id $ \f idx@(Z :. _ :. i :. j) ->
  --   let x = fromIntegral $ i - div numR2Freqs 2
  --       y = fromIntegral $ j - div numR2Freqs 2
  --       r = sqrt $ x ^ 2 + y ^ 2
  --   in if r <= 0
  --        then 0
  --        else f idx
  -- plotImageRepaComplex (folderPath </> "PinwheelFrequency.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelFreq
  -- plotImageRepaComplex (folderPath </> "PinwheelFrequencySeries.png") .
  --   ImageRepa 8 $
  --   pinwheelFreqSeries
  initVec <-
    (VS.fromList . L.map (\x -> x :+ 0)) <$>
    M.replicateM (numPoints ^ 2) randomIO
  lock <- getFFTWLock
  plan <-
    fst <$> idft1dGPlan lock emptyPlan [numPoints, numPoints] [0, 1] initVec
  -- dftPinwheel <-
  --   dftExecute plan (DFTPlanID IDFT1DG [numPoints, numPoints] [0, 1]) .
  --   VU.convert . toUnboxed . computeUnboxedS . makeFilter2D $
  --   pinwheel
  -- plotImageRepaComplex (folderPath </> "DFTPinwheel.png") .
  --   ImageRepa 8 .
  --   computeUnboxedS .
  --   makeFilter2D .
  --   fromUnboxed (Z :. (1 :: Int) :. numPoints :. numPoints) . VS.convert $
  --   dftPinwheel
  let centerR2Freq = div numR2Freqs 2
      gaussian2D =
        computeUnboxedS . fromFunction (Z :. numR2Freqs :. numR2Freqs) $ \(Z :. i' :. j') ->
          let i = i' - centerR2Freq
              j = j' - centerR2Freq
              rho = (sqrt . fromIntegral $ i ^ 2 + j ^ 2) / periodR2 * 2*pi
           in (-- rho ^ (abs angularFreq) *
               exp
                 (pi * fromIntegral (i ^ 2 + j ^ 2) /
                  ((-1) * periodR2 ^ 2 * std ^ 2)) /
               (2 * pi * std ^ 2)) :+
              0
      -- pinwheelFreqAnaticalNonGaussian =
      --   centerHollowArray numR2Freqs . computeUnboxedS $
      --   analyticalFourierCoefficients2
      --     numR2Freqs
      --     delta
      --     angularFreq
      --     radialFreq
      --     (-sigma) --(sigma - 1)
      --     periodR2
      --     (periodEnvelope * sqrt 2)
      pinwheelFreqAnatical =
        centerHollowArray numR2Freqs .
        computeUnboxedS
        -- . R.zipWith (*) gaussian2D
        $
        analyticalFourierCoefficients2
          numR2Freqs
          delta
          angularFreq
          radialFreq
          (-sigma) --(sigma - 1)
          periodR2
          (periodEnvelope * sqrt 2)
      -- pinwheelFreqAnaticalMat =
      --   A.use .
      --   A.fromList (A.Z A.:. (numR2Freqs ^ 2) A.:. (1 :: Int)) . R.toList $
      --   pinwheelFreqAnatical
      -- pinwheelFreqAnaticalInner =
      --   centerHollowArray numR2Freqs . computeUnboxedS $
      --   analyticalFourierCoefficients2'
      --     numR2Freqs
      --     (1 / fromIntegral (div numR2Freqs 2))
      --     angularFreq
      --     radialFreq
      --     (-sigma)
      --     periodR2
      --     (periodEnvelope * sqrt 2)
      -- pinwheelFreqAnaticalInnerMat =
      --   A.use .
      --   A.fromList (A.Z A.:. (numR2Freqs ^ 2) A.:. (1 :: Int)) . R.toList $
      --   pinwheelFreqAnaticalInner
      -- pinwheelFreqSeriesAnatical =
      --   computeUnboxedS $
      --   analyticalFourierSeries1
      --     numPoints
      --     1 -- delta
      --     angularFreq
      --     radialFreq
      --     (sigma - 1)
      --     periodR2
  plotImageRepaComplex (folderPath </> "PinwheelCoefficientsAnalytical.png") .
    ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
    pinwheelFreqAnatical
  -- plotImageRepaComplex
  --   (folderPath </> "PinwheelCoefficientsAnalyticalNonGaussian.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelFreqAnaticalNonGaussian
  -- plotImageRepaComplex
  --   (folderPath </> "PinwheelCoefficientsAnalyticalInner.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelFreqAnaticalInner
  -- plotImageRepaComplex (folderPath </> "PinwheelFrequencySeriesAnalytical.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelFreqSeriesAnatical
  -- pinwheelFreqSeriesStream <-
  --   computeFourierSeriesR2Stream
  --     deviceIDs
  --     ptxs
  --     numR2Freqs
  --     numPoints
  --     periodR2
  --     delta
  --     numBatch
  --     [transposeCuMat pinwheelFreqMat]
  -- plotImageRepaComplex (folderPath </> "PinwheelFrequencySeriesStream.png") .
  --   ImageRepa 8 . computeS . R.traverse pinwheelFreqSeriesStream id $ \f idx@(Z :. _ :. i :. j) ->
  --   let x = fromIntegral $ i - div numPoints 2
  --       y = fromIntegral $ j - div numPoints 2
  --       r = sqrt $ x ^ 2 + y ^ 2
  --   in if r <= 0
  --        then 0
  --        else f idx
  -- pinwheelCoefficientsAnalyticalSeriesStream <-
  --   computeFourierSeriesR2StreamAcc
  --     ptxs
  --     numR2Freqs
  --     numPoints
  --     1
  --     periodR2
  --     deltaRecon
  --     numBatch
  --     pinwheelFreqAnaticalMat
  --     -- [ transposeCuMat . createCuMat $
  --     --   [VU.convert . toUnboxed $ pinwheelFreqAnatical]
  --     -- ]
  -- plotImageRepaComplex
  --   (folderPath </> "PinwheelCoefficientsAnalyticalSeries.png") .
  --   ImageRepa 8 .
  --   computeS .
  --   extend (Z :. (1 :: Int) :. All :. All) .
  --   R.traverse (sumS . rotate3D $ pinwheelCoefficientsAnalyticalSeriesStream) id $ \f idx@(Z :. i :. j) ->
  --   let x = fromIntegral $ i - center
  --       y = fromIntegral $ j - center
  --       r = sqrt $ x ^ 2 + y ^ 2
  --      -- if r <= 6
  --      --   then 0
  --      --   else
  --    in f idx
  pinwheelCoefficientsAnalyticalIDFT <-
    dftExecute plan (DFTPlanID IDFT1DG [numPoints, numPoints] [0, 1]) .
    VU.convert . toUnboxed . computeS . makeFilter2D $
    pinwheelFreqAnatical
  plotImageRepaComplex (folderPath </> "PinwheelCozefficientsIDFT.png") .
    ImageRepa 8 .
    computeS .
    makeFilter2DInverse .
    fromUnboxed (Z :. (1 :: Int) :. numPoints :. numPoints) . VS.convert $
    pinwheelCoefficientsAnalyticalIDFT
  -- pinwheelCoefficientsAnalyticalInnerSeriesStream <-
  --   computeFourierSeriesR2StreamAcc'
  --     ptxs
  --     numR2Freqs
  --     numPoints
  --     1
  --     periodR2
  --     1 -- (1 / fromIntegral (div numR2Freqs 2))
  --     numBatch
  --     pinwheelFreqAnaticalMat
  -- plotImageRepaComplex
  --   (folderPath </> "PinwheelCoefficientsAnalyticalInnverSeries.png") .
  --   ImageRepa 8 .
  --   computeS . extend (Z :. (1 :: Int) :. All :. All) . sumS . rotate3D $
  --   pinwheelCoefficientsAnalyticalInnerSeriesStream
  -- plotImageRepaComplex
  --   (folderPath </> "PinwheelCoefficientsAnalyticalSumSeries.png") .
  --   ImageRepa 8 .
  --   computeS . extend (Z :. (1 :: Int) :. All :. All) . sumS . rotate3D $
  --   R.zipWith
  --     (+)
  --     pinwheelCoefficientsAnalyticalSeriesStream
  --     pinwheelCoefficientsAnalyticalInnerSeriesStream
  --   computeS . R.traverse pinwheelCoefficientsAnalyticalSeriesStream id $ \f idx@(Z :. _ :. i :. j) ->
  --   let x = fromIntegral $ i - div numPoints 2
  --       y = fromIntegral $ j - div numPoints 2
  --       r = sqrt $ x ^ 2 + y ^ 2
  --   in if r <= 0
  --        then 0
  --        else f idx
  -- -- pinwheelCoefficientsSeriesStream <-
  --   computeFourierSeriesR2Stream
  --     deviceIDs
  --     ptxs
  --     numR2Freqs
  --     numPoints
  --     periodR2
  --     delta
  --     numBatch
  --     [transposeCuMat . createCuMat $ [VU.convert . toUnboxed $ pinwheelCoef]]
  -- plotImageRepaComplex (folderPath </> "PinwheelCoefficientsSeriesStream.png") .
  --   ImageRepa 8 . computeS . R.traverse pinwheelCoefficientsSeriesStream id $ \f idx@(Z :. _ :. i :. j) ->
  --   let x = fromIntegral $ i - div numPoints 2
  --       y = fromIntegral $ j - div numPoints 2
  --       r = sqrt $ x ^ 2 + y ^ 2
  --   in if r <= 0
  --        then 0
  --        else f idx
  -- let besselFilter =
  --       computeUnboxedS . fromFunction (Z :. numR2Freqs :. numR2Freqs) $ \(Z :. i :. j) ->
  --         let xFreq = fromIntegral $ i - centerFreq
  --             yFreq = fromIntegral $ j - centerFreq
  --             rho = sqrt $ xFreq ^ 2 + yFreq ^ 2
  --         in if rho == 0
  --              then 1
  --              else (bessel_J1 (2 * pi * rho / periodR2)) / rho :+ 0
  -- plotImageRepaComplex (folderPath </> "BesselFilter.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   besselFilter
  -- initVec1 <-
  --   (VS.fromList . L.map (\x -> x :+ 0)) <$>
  --   M.replicateM (numR2Freqs ^ 2) randomIO
  -- lock <- getFFTWLock
  -- plan <-
  --   fst <$>
  --   (dft1dGPlan lock emptyPlan [numR2Freqs, numR2Freqs] [0, 1] initVec1 >>= \(plan, vec) ->
  --      idft1dGPlan lock plan [numR2Freqs, numR2Freqs] [0, 1] vec)
  -- let besselVec =
  --       VU.convert . toUnboxed . computeS . makeFilter2D $ besselFilter
  --     pinwheelFreqAnaticalVec = VU.convert . toUnboxed $ pinwheelFreqAnatical
  -- besselVecF <-
  --   dftExecute plan (DFTPlanID DFT1DG [numR2Freqs, numR2Freqs] [0, 1]) besselVec
  -- pinwheelFreqAnaticalVecF <-
  --   dftExecute
  --     plan
  --     (DFTPlanID DFT1DG [numR2Freqs, numR2Freqs] [0, 1])
  --     pinwheelFreqAnaticalVec
  -- pinwheelFreqAnatical1 <-
  --   fmap (fromUnboxed (Z :. numR2Freqs :. numR2Freqs) . VS.convert) .
  --   dftExecute plan (DFTPlanID IDFT1DG [numR2Freqs, numR2Freqs] [0, 1]) $
  --   VS.zipWith (*) besselVecF pinwheelFreqAnaticalVecF
  -- plotImageRepaComplex
  --   (folderPath </> "BesselFilterConveledPinwheelFreqAnatical.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelFreqAnatical1
  -- let pinwheelFreqAnatical2 =
  --       R.zipWith (-) pinwheelFreqAnatical pinwheelFreqAnatical1
  --     pinwheelFreqAnaticalMat2 =
  --       A.use .
  --       A.fromList (A.Z A.:. (numR2Freqs ^ 2) A.:. (1 :: Int)) . R.toList $
  --       pinwheelFreqAnatical2
  -- plotImageRepaComplex (folderPath </> "pinwheelFreqAnatical2.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   pinwheelFreqAnatical2
  -- pinwheelCoefficientsAnalyticalSeriesStream2 <-
  --   computeFourierSeriesR2StreamAcc
  --     ptxs
  --     numR2Freqs
  --     numPoints
  --     1
  --     periodR2
  --     delta
  --     numBatch
  --     pinwheelFreqAnaticalMat2
  -- plotImageRepaComplex
  --   (folderPath </> "PinwheelCoefficientsAnalyticalSeries2.png") .
  --   ImageRepa 8 .
  --   computeS . extend (Z :. (1 :: Int) :. All :. All) . sumS . rotate3D $
  --   pinwheelCoefficientsAnalyticalSeriesStream2
  -- dftPinwheel <-
  --   fmap (fromUnboxed (Z :. numR2Freqs :. numR2Freqs) . VS.convert) .
  --   dftExecute plan (DFTPlanID DFT1DG [numR2Freqs, numR2Freqs] [0, 1]) .
  --   VU.convert . toUnboxed . computeS . makeFilter2D $
  --   pinwheel
  -- let zeroArr =
  --       fromFunction (Z :. numR2Freqs :. numR2Freqs) $ \(Z :. i :. j) ->
  --         if (sqrt . fromIntegral $ (i - centerFreq) ^ 2 + (j - centerFreq) ^ 2) <
  --            1
  --           then 0
  --           else 1
  -- plotImageRepaComplex (folderPath </> "DFTPinwheel.png") .
  --   ImageRepa 8 .
  --   computeS .
  --   extend (Z :. (1 :: Int) :. All :. All) .
  --   R.zipWith (*) zeroArr . makeFilter2D $
  --   dftPinwheel
  -- let normFunc arr =
  --       let m = VU.maximum . toUnboxed . computeS . R.map magnitude $ arr
  --       in R.map (/ (m :+ 0)) arr
  -- plotImageRepaComplex (folderPath </> "Diff.png") .
  --   ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
  --   R.zipWith
  --     (\a b ->
  --        if magnitude b == 0
  --          then 0
  --          else a / b)
  --     (normFunc . R.zipWith (*) zeroArr . makeFilter2D $ dftPinwheel)
  --     (normFunc . R.zipWith (*) zeroArr $ pinwheelFreqAnatical)


{-# LANGUAGE OverloadedStrings #-}
module VisualizeFunction where
import Control.Monad
import Data.Binary.Put
import Numeric.LinearAlgebra.HMatrix
import System.IO
import qualified Data.ByteString.Lazy as L
import qualified Data.Vector.Storable as V

-- derived from description at https://en.wikipedia.org/wiki/BMP_file_format
putBMPHeader headerLength imageLength = do
    putLazyByteString "BM" -- magic identifier
    putWord32le (headerLength + imageLength) -- total length of file (bytes)
    putLazyByteString "HELO" -- apparently a reserved field which can be filled arbitrarily
    putWord32le headerLength -- offset of pixel array in the file (bytes)

putBitmapInfoHeader (width, height) bpp = do
    putWord32le 40 -- size of BITMAPINFOHEADER
    putWord32le $ fromIntegral width
    putWord32le $ fromIntegral (-height) -- negative height -> first row is top of image
    putWord16le 1 -- # of color planes
    putWord16le bpp -- bits per pixel
    putWord32le 0 -- compression method (uncompressed RGB is 0)
    putWord32le 0 -- uncompressed size (optional if no compression is used)
    replicateM_ 2 $ putWord32le 0 -- dummy values for {x,y}-resolution
    putWord32le 0 -- use all 2^bpp colors
    putWord32le 0 -- # of "important colors", which is "generally ignored"

addBitmapHeader (w, h) image = do
    let headerLength = (2 + 4 + 4 + 4) + 40
    let imageLength = fromIntegral $ L.length image
    putBMPHeader headerLength imageLength
    putBitmapInfoHeader (w, h) 32
    putLazyByteString image

putRGB r g b = mapM_ putWord8 [b,g,r,0]

scaleFromTo (a, b) (a', b') x = ((x-a)/(b-a))*(b'-a')+a'

putPixel x y z = putRGB r g b where
    minimum = 0
    maximum = 2^8 - 1
    r = round $ if z < 0 then scaleFromTo (0, -1) (minimum, maximum) z else minimum
    g = round $ minimum
    b = round $ if z > 0 then scaleFromTo (0, 1) (minimum, maximum) z else minimum

visualizeFunction (xmin, ymin) (xmax, ymax) (w, h) (zmin, zmax) f = runPut image where
    xs = linspace w (xmin, xmax)
    ys = linspace h (ymin, ymax)
    f' = scaleFromTo (zmin, zmax) (-1, 1) . f
    image = V.forM_ ys (\y -> V.forM_ xs (\x -> putPixel x y (f' $ vector [x,y])))

visualizeFunctionBMP min max dims range = runPut . addBitmapHeader dims . visualizeFunction min max dims range

saveImage name img = withBinaryFile name WriteMode $ \h -> L.hPutStr h img

emitSample = saveImage "sample.bmp" $ visualizeFunctionBMP (-1,-1) (1,1) (2048, 2048) (-1,1) (tanh . V.sum)