text:
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

max_stars_repo_name: avanmeul/PlottingAndSchemingHaskell

max_issues_repo_name: avanmeul/PlottingAndSchemingHaskell

max_forks_repo_name: avanmeul/PlottingAndSchemingHaskell


text:
{-# OPTIONS_GHC -Wall #-}

module Numeric.FFT.HMatrix.Vector (
  -- * Complex-to-complex transforms
  dft
  , idft
    -- * Real-to-complex transforms
  , dftR2C
  , dftC2R
    -- * Real-to-real transforms
    -- ** Discrete cosine transforms
  , dct1
  , dct2
  , dct3
  , dct4
    -- ** Discrete sine transforms
  , dst1
  , dst2
  , dst3
  , dst4
  ) where

import Foreign.Storable ( Storable )
import Numeric.LinearAlgebra.Data ( Vector, Complex )
import Numeric.LinearAlgebra ( Element )
import qualified Numeric.LinearAlgebra.Data as M
import qualified Numeric.FFT.Vector.Unnormalized as FFT

dft :: Vector (Complex Double) -> Vector (Complex Double)
dft = FFT.run FFT.dft

idft :: Vector (Complex Double) -> Vector (Complex Double)
idft = FFT.run FFT.idft

dftR2C :: Vector Double -> Vector (Complex Double)
dftR2C = FFT.run FFT.dftR2C

dftC2R :: Vector (Complex Double) -> Vector Double
dftC2R = FFT.run FFT.dftC2R

dct1 :: Vector Double -> Vector Double
dct1 = FFT.run FFT.dct1

dct2 :: Vector Double -> Vector Double
dct2 = FFT.run FFT.dct2

dct3 :: Vector Double -> Vector Double
dct3 = FFT.run FFT.dct3

dct4 :: Vector Double -> Vector Double
dct4 = FFT.run FFT.dct4

dst1 :: Vector Double -> Vector Double
dst1 = FFT.run FFT.dst1

dst2 :: Vector Double -> Vector Double
dst2 = FFT.run FFT.dst2

dst3 :: Vector Double -> Vector Double
dst3 = FFT.run FFT.dst3

dst4 :: Vector Double -> Vector Double
dst4 = FFT.run FFT.dst4

ext: hs

max_stars_repo_name: peddie/hmatrix-fftw

max_issues_repo_name: peddie/hmatrix-fftw

max_forks_repo_name: peddie/hmatrix-fftw


text:
-- | This module implements the Fast Fourier Transformation purely in Haskell.
module Sound.Hommage.FFT
 (
 -- * FFT
   fft
 , fft'
 , fftt

 -- * FFT
 , fftc
 , fftc'

 , ffttv

 , fftco
 , fftco'

 , rect_transform
 , rect_filter
 , rect_filter'

 , i
 , w
 , ws
 , map2
 , zip2
 , evens
 , odds
 , drop_odds
 , appendpair
-- , fitlastlength
 , reorder
 , reorder_init
 , reorder_init'
-- , reorder_overlap
 , butterfly
 , butterfly'
 , fft_level
 , fft_merge
 , fft_init_overlap
 , fft_level'
 , fft_merge'
 , fft_init
 , fft_overlap_loop
 , expandComplex
 , overlap_curve
 , mix_overlap

 )
 where
import Data.Complex
import Sound.Hommage.Misc
-------------------------------------------------------------------------------
-- | The complex value 'i' = @(0 :+ 1)@
i :: Complex Double
i = 0.0 :+ 1.0

-- | The n-th root of 1
w :: Int -> Complex Double
w n = exp (-2 * i * pi / fromIntegral n)

-- | the 2n-th root with exponents 0, 1, .. n. False=inverse (exponents are negated)
ws :: Bool -> Int -> [Complex Double]
ws b n = take n $ map (w1^^) ix
 where
  w1 = exp (-i * pi / fromIntegral n)
  ix | b         = [0, 1 ..]
     | otherwise = [0, (-1) ..]
-------------------------------------------------------------------------------
map2 :: (a -> a -> b) -> [a] -> [b]
map2 f (x:y:r) = f x y : map2 f r
map2 _ _       = []

map2opt :: (a -> a -> b) -> a -> [a] -> [b]
map2opt f a = loop
 where
  loop (x:y:r) = f x y : loop r
  loop [x]     = [f x a]
  loop _       = []

zip2 :: [a] -> [a] -> [a]
zip2 (x:xs) (y:ys) = x : y : zip2 xs ys
zip2 _ _ = []

evens (x:xs) = x : odds xs
evens []     = []

odds (_:xs) = evens xs
odds []     = []

-- | returns [] if argument has zero or one element.
drop_odds (x:y:r) = x : evens r
drop_odds _       = []

appendpair :: ([a], [a]) -> [a]
appendpair (x,y) = x++y

--fitlastlength :: Int -> a -> [[a]] -> [[a]]
--fitlastlength n a = loop
-- where
--  loop (x:xs) = case loop xs of
--                [] -> [take n (x ++ repeat a)]
--                xs -> x : xs
--  loop []     = []
-------------------------------------------------------------------------------
-- | list is grouped into sublists with length N (must be power of 2) and bitwise reverse order
reorder :: Int -> [[a]] -> [[a]]
reorder 0 = id
reorder n = map2 zip2 . reorder (n-1)

reorder_r2 :: Int -> a -> [[a]] -> [[a]]
reorder_r2 n a = loop n
 where
  loop 0 = id
  loop n = map2opt zip2 (repeat a) . loop (n-1)

reorder_init (x1:x2:x3:x4:xs) = [x1 :+ x2, x3 :+ x4] : reorder_init xs
reorder_init [x1,x2,x3]       = [[x1 :+ x2, x3 :+ 0]]
reorder_init [x1,x2]          = [[x1 :+ x2, 0]]
reorder_init [x1]             = [[x1 :+ 0, 0]]
reorder_init _                = []

reorder_init' :: [a] -> [[a]]
reorder_init' (x:y:r) = [x,y] : reorder_init' r
reorder_init' _       = []

reorder_init_r2' :: a -> [a] -> [[a]]
reorder_init_r2' a = loop
 where
  loop (x:y:r) = [x,y] : loop r
  loop [x]     = [[x,a]]
  loop _       = []

--reorder_overlap :: [[a]] -> [a]
--reorder_overlap (xs:ys:r) = (zip2 xs ys) ++ reorder_overlap (ys:r)
--reorder_overlap _       = []
-------------------------------------------------------------------------------
butterfly :: Complex Double ->  Complex Double -> Complex Double -> (Complex Double, Complex Double)
butterfly (wr :+ wi) (xr :+ xi) (yr :+ yi) = (a, b)
 where
  wyr = wr*yr-wi*yi
  wyi = wr*yi+yr*wi
  a = ( (xr + wyr) * 0.5 :+ (xi + wyi) * 0.5 )
  b = ( (xr - wyr) * 0.5 :+ (xi - wyi) * 0.5 )

butterfly' :: Complex Double ->  Complex Double -> Complex Double -> (Complex Double, Complex Double)
butterfly' (wr :+ wi) (xr :+ xi) (yr :+ yi) = (a, b)
 where
  wyr = wr*yr-wi*yi
  wyi = wr*yi+yr*wi
  a = ( (xr + wyr) :+ (xi + wyi) )
  b = ( (xr - wyr) :+ (xi - wyi) )
-------------------------------------------------------------------------------
-- | FFT transformation. Input is grouped into overlapping parts of 2^(N+2) reals and mapped to sublists
--   with 2^(N+1) complex numbers.
fft :: Int -> [Double] -> [[Complex Double]]
fft n = fft_level (ws True (2^n)) . fft_init_overlap . reorder_r2 (n-1) 0 . reorder_init

fft_level :: [Complex Double] -> [[Complex Double]] -> [[Complex Double]]
fft_level [_] = id
fft_level ws  = map2 (\x -> appendpair . fft_merge ws x) . fft_level (drop_odds ws)

fft_merge :: [Complex Double] -> [Complex Double] -> [Complex Double] -> ([Complex Double], [Complex Double])
fft_merge (w:ws) (x:xs) (y:ys) = let (xs', ys') = fft_merge ws xs ys
                                     (x', y') = butterfly w x y
                                 in (x' : xs', y' : ys')
fft_merge _ _ _ = ([], [])

fft_init_overlap (x:y:r) = (zipWith (\x y -> [(x + y)*0.5, (x - y)*0.5]) x y) ++ fft_init_overlap (y:r)
fft_init_overlap _       = []

fft_init (x:y:r) = (zipWith (\x y -> [(x + y)*0.5, (x - y)*0.5]) x y) ++ fft_init r
fft_init _       = []
-------------------------------------------------------------------------------
-- | Inverse FFT transformation. Complex input is grouped into parts with length 2^(N+1) and mapped to
--   sublists with 2^(N+2) reals, which are overlapped and mixed.
fft' :: Int -> [Complex Double] -> [Double]
fft' n = mix_overlap (2^(n+2)) . map expandComplex . fft_level' (ws False (2^n)) . fft_init' . reorder (n-1) . reorder_init'

fft_level' :: [Complex Double] -> [[Complex Double]] -> [[Complex Double]]
fft_level' [_] = id
fft_level' ws  = map2 (\x -> appendpair . fft_merge' ws x) . fft_level' (drop_odds ws)

fft_merge' :: [Complex Double] -> [Complex Double] -> [Complex Double] -> ([Complex Double], [Complex Double])
fft_merge' (w:ws) (x:xs) (y:ys) = let (xs', ys') = fft_merge' ws xs ys
                                      (x', y') = butterfly' w x y
                                  in (x' : xs', y' : ys')
fft_merge' _ _ _ = ([], [])

fft_init' (x:y:r) = (zipWith (\x y -> [x + y, x - y]) x y) ++ fft_init' r
fft_init' _       = []

fft_overlap_loop (x:r@(y:_)) = (concat $ zipWith (\x y -> [x + y, x - y]) x y) : fft_overlap_loop r
fft_overlap_loop _           = []

expandComplex ((x:+y):r) = x : y : expandComplex r
expandComplex _ = []
-------------------------------------------------------------------------------
-- | Creates a fade with length N
overlap_curve :: Int -> [Double]
overlap_curve n = take n $ map (\k -> 0.5 - 0.5 * cos (fromIntegral k * 2 * pi / fromIntegral n )) [0..]

-- | Overlaps a sequence of parts of length N (overlaps by N\/2).
mix_overlap :: Int -> [[Double]] -> [Double]
mix_overlap n xs = merge (+) l r
  where
  c = cycle $ overlap_curve n
  l = zipWith (*) c $ concat $ evens xs
  r = replicate (div n 2) 0.0 ++ (zipWith (*) c $ concat $ odds xs)
-------------------------------------------------------------------------------
-- | FFT transformation with overlapping and windowing.
--   Argument function maps the coefficients. Windowsize: 2^(N+2), i. e. 2^(N+1) coefficients
fftt :: Int -> ([[Complex Double]] -> [Complex Double]) -> [Double] -> [Double]
fftt n f =
 mix_overlap (2^(n+2)) .
 map expandComplex .
 fft_level' (ws False (2^n)) .
 fft_init' .
 reorder (n-1) .
 reorder_init' .
 f .
 fft_level (ws True (2^n)) .
 fft_init_overlap .
 reorder_r2 (n-1) 0 .
 reorder_init

ffttv :: Int -> [Double] -> [Double] -> [Double]
ffttv n vs = fftt n (zipWith (\v (x:+y) -> (v*x) :+ (v*y)) vs . concat . map (\((a:+_):r) -> (a:+0):r))
-------------------------------------------------------------------------------
-- | FFT transformation for complex input (segments of length 2^n).
--   No overlapping or windowing.
fftc :: Int -> [Complex Double] -> [[Complex Double]]
fftc n = fft_level (ws True (2^n)) . fft_init . reorder_r2 (n-1) 0 . reorder_init_r2' 0

-- | Inverse FFT transformation for complex input (segments of length 2^n).
--   No overlapping or windowing.
fftc' :: Int -> [Complex Double] -> [[Complex Double]]
fftc' n = fft_level' (ws False (2^n)) . fft_init' . reorder (n-1) . reorder_init'
-------------------------------------------------------------------------------
-- | FFT for complex input with overlapping. Segment-size: 2^(n+1)
fftco :: Int -> [Complex Double] -> [[Complex Double]]
fftco n = fft_level (ws True (2^n)) . fft_init_overlap . reorder_r2 (n-1) 0 . reorder_init_r2' 0

fftco' :: Int -> [Complex Double] -> [Complex Double]
fftco' n = mix_overlapc (2^(n+1)) . fft_level' (ws False (2^n)) . fft_init' . reorder (n-1) . reorder_init'

-- | Overlaps a sequence of parts of length N (overlaps by N\/2).
mix_overlapc :: Int -> [[Complex Double]] -> [Complex Double]
mix_overlapc n xs = merge (+) l r
  where
  c = cycle $ map (:+0) $ overlap_curve n
  l = zipWith (*) c $ concat $ evens xs
  r = replicate (div n 2) 0.0 ++ (zipWith (*) c $ concat $ odds xs)
-------------------------------------------------------------------------------

-- | A self-inverse transformation similar to FFT but with a simple butterfly
--   operation that uses always W=1. Modifying the data between application
--   and inverse is similar to filtering but the result will be built up from
--   rectangle waves instead of sinus waves.
rect_transform :: Floating a => Int -> [a] -> [[a]]
rect_transform n = run n . map (:[])
 where
  sq = 1 / sqrt 2
  add x y = (x+y) * sq
  sub x y = (x-y) * sq
  run 0 = id
  run n = loop . run (n-1)
  loop (x:y:r) = iter True x y : loop r
  loop [x]     = [iter True x (repeat 0)]
  loop _       = []
  iter True  (x:xs) (y:ys) = add x y : sub x y : iter False xs ys
  iter False (x:xs) (y:ys) = sub x y : add x y : iter True  xs ys
  iter _     _      _      = []

rect_filter :: Floating a => Int -> ([[a]] -> [[a]]) -> [a] -> [a]
rect_filter n f =  concat . rect_transform n . concat . f . rect_transform n

rect_filter' :: Floating a => Int -> [[a]] -> [a] -> [a]
rect_filter' n vs =  concat . rect_transform n . concat . zipWith f vs . rect_transform n
 where
  f v c = zipWith (*) (v ++ repeat 0) c

max_stars_repo_name: aische/hommage

max_issues_repo_name: aische/hommage

max_forks_repo_name: aische/hommage


text:
{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}

module Main where

import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Async
import           Control.Concurrent.MVar
import           Control.Monad
import           Data.IORef
import           Data.Time.Clock.POSIX
import           Data.Time.Units
import           Data.Vector (Vector, fromList)
import qualified Data.Vector as V (length)
import           Data.Word (Word32)
import           Network.QDisc.Fair
import           Network.Transport.TCP (QDisc (..), simpleOnePlaceQDisc, simpleUnboundedQDisc)
import           Statistics.Distribution
import           Statistics.Distribution.Exponential
import           Statistics.Distribution.Normal
import           Statistics.Distribution.Uniform
import qualified Statistics.Sample as Sample
import           System.Environment (getArgs)
import           System.Random.MWC

-- | A writer is determined by some continuous distribution giving the duration
--   (in microseconds) between successive data being made available.
data SimulationWriter = forall distr . ContGen distr => SimulationWriter distr

-- | A reader is determined by some continuous distribution giving the duration
--   (in microseconds) between successive reads (how long the reader thread
--   works between taking events).
data SimulationReader = forall distr . ContGen distr => SimulationReader distr

data Scenario = Scenario {
      sim_reader  :: SimulationReader
    , sim_writers :: [SimulationWriter]
    }

data SimulationParameters = SimulationParameters {
      sim_scenario :: Scenario
      -- | How long the simulation should run.
    , sim_duration :: Second
      -- | The QDisc to use.
    , sim_qdisc    :: QDisc ()
      -- | A seed for randomness.
    , sim_seed     :: Word32
    }

type Latency = Double

-- | The output of a simulation is, for each writer, the samples of actual
--   delays observed when trying to write: how long it was blocked on
--   trying to enqueue. The number of samples is the number of writes it
--   made.
data SimulationOutput = SimulationOutput {
      sim_writer_outputs :: [Vector Latency]
    }

instance Show SimulationOutput where
    show (SimulationOutput vecs) = concat $ flip fmap vecs $ \vec -> concat [
          "Samples (writes): ", show (V.length vec), "\n"
        , "Latency (microseconds):\n"
        , "  Mean: ", show (Sample.mean vec), "\n"
        , "  Std. Dev.: ", show (Sample.stdDev vec), "\n\n"
        ]

data QDiscChoice = Fair | OnePlace | Unbounded

makeQDisc :: QDiscChoice -> IO (QDisc t)
makeQDisc choice = case choice of
    Fair      -> fairQDisc (const (return Nothing))
    Unbounded -> simpleUnboundedQDisc
    OnePlace  -> simpleOnePlaceQDisc

unfairScenario :: Scenario
unfairScenario = Scenario {
      -- Difference between fair and one-place is very clear here.
      -- The two fast writers get the same number of writes in either case.
      -- One-place gives the slow writer half as many writes, but fair gives
      -- it a lot more. The cycle time (time to read from all 3 writers) is
      -- the slow writer's write delay, so we expect that the slow writer
      -- should be able to write on every cycle.
      sim_reader = SimulationReader (uniformDistr 5000 5001)
    , sim_writers = [
            SimulationWriter (uniformDistr 4999 5000)
          , SimulationWriter (uniformDistr 4999 5000)
          , SimulationWriter (uniformDistr 14999 15000)
          ]
    }

-- | A normally-distributed reader (mean and std. dev. configurable) and
--   n exponentially-distributed writers (means configurable).
typicalScenario :: (Double, Double) -> [Double] -> Scenario
typicalScenario (rmean, rstd_dev) writers = Scenario {
      sim_reader = SimulationReader (normalDistr rmean rstd_dev)
    , sim_writers = flip fmap writers $ \wmean -> SimulationWriter (exponential (1/wmean))
    }

simpleSimulationParameters :: QDisc () -> Second -> Scenario -> SimulationParameters
simpleSimulationParameters qdisc duration scenario = SimulationParameters {
      sim_scenario = scenario
    , sim_duration = duration
    , sim_qdisc = qdisc
    , sim_seed = 42
    }

-- | Run a simulation.
simulate :: SimulationParameters -> IO SimulationOutput
simulate SimulationParameters{..} = do

    let Scenario{..} = sim_scenario

    -- All threads will wait on this.
    -- Threads will loop, and at each iteration will read it. If it's True,
    -- they'll stop.
    startStop :: MVar Bool <- newEmptyMVar

    -- Spawn the reader.
    refs <- withAsync (reader 0 sim_reader) $ \readerThread -> do
        -- Spawn the writers.
        writerThreadsAndRefs <- forM (zip [1..] sim_writers) $ \(seed', sim_writer) -> do
            (ref, doWrites) <- writer startStop seed' sim_writer
            --withAsync doWrites $ \thread -> return (ref, thread)
            thread <- async doWrites
            return (ref, thread)
        -- Duration is in seconds.
        putMVar startStop False
        threadDelay $ fromIntegral sim_duration * 1000000
        swapMVar startStop True
        forM writerThreadsAndRefs $ \(ref, thread) -> do
            wait thread
            return ref

    -- Reader and writers are all killed. Results available in the IORefs.
    vectors <- forM refs (fmap fromList . readIORef)

    return $ SimulationOutput ((fmap . fmap) fromIntegral vectors)

    where

    reader :: Word32 -> SimulationReader -> IO ()
    reader seed' (SimulationReader distribution) = do
        gen <- initialize (fromList [sim_seed, seed'])
        let readLoop = do
                () <- qdiscDequeue sim_qdisc
                -- Unlike for writers, the reader delays are always respected,
                -- as the delay is independent of how long the reader waits for
                -- a value from qdiscDequeue.
                delay :: Microsecond <- fromIntegral . round <$> genContVar distribution gen
                threadDelay (fromIntegral delay)
                readLoop
        readLoop

    writer :: MVar Bool -> Word32 -> SimulationWriter -> IO (IORef [Microsecond], IO ())
    writer control seed' (SimulationWriter distribution) = do
        ref <- newIORef []
        gen <- initialize (fromList [sim_seed, seed'])
        -- The writer's distribution determines the duration between the points
        -- in time when new data are made available, and this is independent
        -- of how long it takes to actually do the write. For instance, if
        -- the writer is blocked on enqueue for 2 seconds, and the distribution
        -- says there will be data available every 1 second, then 2 data will
        -- be immediately available after the enqueue finishes.
        let writeLoop :: Microsecond -> IO ()
            writeLoop surplusWait = do
                stop <- readMVar control
                unless stop $ do
                    nextDelay :: Microsecond <- fromIntegral . round <$> genContVar distribution gen
                    let actualDelay = nextDelay - surplusWait
                    when (actualDelay > 0) $ do
                        threadDelay (fromIntegral actualDelay)
                    start <- getPOSIXTime
                    qdiscEnqueue sim_qdisc undefined undefined ()
                    end <- getPOSIXTime
                    let latency :: Microsecond
                        !latency = fromIntegral . round $ (realToFrac (end - start) :: Double) * 1000000
                    modifyIORef' ref ((:) latency)
                    let !surplusWait' = max 0 (surplusWait + latency - nextDelay)
                    writeLoop surplusWait'
        return (ref, writeLoop 0)

main :: IO ()
main = do
    args <- getArgs
    qdiscChoice <- case args of
        "unbounded" : _ -> putStrLn "Using unbounded QDisc" >> return Unbounded
        "one_place" : _ -> putStrLn "Using one-place QDisc" >> return OnePlace
        _               -> putStrLn "Using fair QDisc" >> return Fair
    duration :: Int <- case args of
        _ : n : _ -> case reads n of
            [(n', "")] -> return n'
        _ -> return 10
    qdisc <- makeQDisc qdiscChoice
    --let scenario = typicalScenario (1000, 25) [800, 900, 1000, 1100, 1200]
    let scenario = unfairScenario
    results <- simulate $ simpleSimulationParameters qdisc (fromIntegral duration) scenario
    putStrLn ""
    print results


text:
-- |
-- Module      : Main
-- Description : Entry point module
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : jonatanhsundqvist@gmail.com
-- Stability   : experimental
-- Portability : POSIX

-- TODO | - JSON key bindings and config
--        - Sharing scores and recordings
--        - Buying premade assets, scores, sound fonts, etc. (user content)
--        - Audio!
--        - 3D audio (move listener around)
--        - Serialisation
--        - IO Lenses (?)
--        - Better way of dealing with state, sharing IO resources
--        - Restrict access to AppState, 'fenced off' IORefs

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Main where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Control.Monad      (forM_, when, forever, liftM)
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.MVar
import Text.Printf
import Data.IORef
import Data.Complex
import Data.StateVar
import Data.Functor
import qualified Data.Set  as S
import qualified Data.Map  as M

import qualified Graphics.Rendering.Cairo as Cairo
import           Graphics.UI.Gtk          as Gtk
import           Graphics.UI.Gtk          (AttrOp(..), on)

import Sound.OpenAL
-- import qualified Sound.ALUT   as Alut

-- Internal module imports
import           BattleHack.Types
import           BattleHack.Lenses
import qualified BattleHack.Render  as Render
import qualified BattleHack.Events  as Events
import qualified BattleHack.Audio   as Audio
import qualified BattleHack.Window  as Window

--------------------------------------------------------------------------------------------------------------------------------------------
-- Entry point
--------------------------------------------------------------------------------------------------------------------------------------------
-- |
main :: IO ()
main = do
  -- Create and configure window
  (window, canvas) <- Window.create winsize

  -- Audio
  -- TODO: Utility function for accessing range indeces
  -- TODO: Don't hard-code range
  -- TODO: Check for errors
  -- Just (context, device) <- Audio.setup -- TODO: Return context as well (probably a good idea) (✓)
  -- [source] <- genObjectNames 1
  -- claviature'            <- Audio.makebuffersFromIndeces (zipWith const [0..] $ replicate 24 False)

  -- App state
  stateref <- newIORef (initalstate 24 origin' keysize') -- claviature')

  --
  -- mnotes <- newMVar . (-->piano.keys) <$> readIORef stateref
  mnotes <- readIORef stateref >>= (newMVar . (-->piano.keys))
  -- mnotes <- return [True, True, False, True] >>= newMVar -- (newMVar . (-->piano.keys))

  -- forkIO $ Audio.stream (1.0/30.0) source mnotes
  let audiofps = 5

  forkIO $ Audio.stream (1.0/audiofps) mnotes

  forkIO $ forever $ do
    putStrLn "New write iteration"
    playing <- (-->piano.keys) <$> readIORef stateref
    putMVar mnotes playing
    threadDelay . ceiling $ (1.0/audiofps) * 10^6
    printf "Next batch coming up!\n"
    printf "These notes: %s.\n\n\n\n" (show playing)

  -- Register event handlers
  Window.bindevents window canvas stateref

  -- Animation
  timeoutAdd (Events.onanimate canvas stateref) (1000 `div` fps)

  -- Enter main loop
  mainGUI
  where
    fps = 30                                   --
    origin'@(ox:+oy)  = 20:+20                 --
    keysize'@(sx:+sy) = (4:+13) * 40           --
    winsize           = (sx*7:+sy) + 2*origin' --

-- | Initial application state
-- TODO: Piano range
initalstate :: Int -> Vector -> Vector -> AppState
initalstate nkeys origin' keysize' = AppState { _piano = PianoSettings { _origin  = origin',
                                                                         _keysize = keysize',
                                                                         _indent  = 0.26,
                                                                         _mid     = 0.62,
                                                                         _active  = Nothing,
                                                                         _keys    = replicate nkeys False },

                                                _animation = AnimationData { _frame = 0,
                                                                             _fps   = 30 },

                                                _inputstate = InputState { _mouse=0:+0, _keyboard=S.empty },
                                                _bindings = M.fromList [("Escape", Cairo.liftIO mainQuit)] }

-- | Just a little hello world snippet to make sure everything is set up properly.
goodbyeWorld :: IO ()
goodbyeWorld = do
  putStrLn "Hello world!"
  putStrLn "Counting down to launch..."
  forM_ [10,9..0] ((>> threadDelay (10^6)) . print)
  putStrLn "Launching. What have I done!?"


text:
{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedLists, BangPatterns, Strict #-}
module Data.Mesh where

import qualified Graphics.Rendering.OpenGL.GL as GL
import           Graphics.Rendering.OpenGL.GL (($=))
import           Control.Lens      hiding (indices)
import qualified Data.Vector.Storable as VS
import           Number.Quaternion (T,real,imag)
import           Numeric.LinearAlgebra (Vector)
import qualified SDL
import qualified SDL.Image as SDLImage
import           Foreign (sizeOf)
import           Foreign.Ptr (intPtrToPtr)
import           Data.Shaders
import           Utils.Quaternions (qZero)
import           Control.Arrow
import           Control.Monad (unless)
import Control.DeepSeq
import Graphics.Rendering.OpenGL.GLU.Errors

instance NFData a => NFData (T a) where
  rnf q = let !_ = real q
              (!_,!_,!_) = imag q
          in ()

instance NFData Mesh where
  rnf m = let !_ = _quaternion m
          in ()

data Mesh = Mesh { _vertices     :: [Vector Float],
                   _indices      :: Vector GL.BaseInstance,
                   _vao          :: GL.VertexArrayObject,
                   _vbo          :: GL.BufferObject,
                   _ebo          :: GL.BufferObject,
                   _shaders      :: Shaders,
                   _quaternion   :: T Float,
                   _texture      :: Maybe GL.TextureObject,
                   _normalMap    :: Maybe GL.TextureObject }

makeLenses ''Mesh

-- loadAndBindImage :: FilePath -> IO ()
loadAndBindImage texType fn = do
  sdlSurf <- SDLImage.load fn
  SDL.V2 w h <- fmap fromIntegral <$> SDL.surfaceDimensions sdlSurf
  SDL.lockSurface sdlSurf
  texturePtr <- SDL.surfacePixels sdlSurf
  let textureSize = GL.TextureSize2D w h
      textureData = GL.PixelData GL.RGB GL.UnsignedByte texturePtr
  GL.texImage2D texType GL.NoProxy 0 GL.RGB' textureSize 0 textureData
  SDL.unlockSurface sdlSurf

loadTexture :: FilePath -> IO GL.TextureObject
loadTexture fn = do
  texName <- GL.genObjectName
  GL.textureBinding GL.Texture2D $= Just texName
  loadAndBindImage GL.Texture2D fn
  GL.textureFilter GL.Texture2D $=
    ((GL.Linear', Nothing),GL.Linear')
  return texName

createMesh (vdata, indices, verts) shad mtex norm = do
    vao <- GL.genObjectName
    GL.bindVertexArrayObject $= Just vao
    ebo <- createAndBindArrayBuffer GL.ElementArrayBuffer $ indices
    vbo <- createAndBindArrayBuffer GL.ArrayBuffer $ vdata

    setAttrib 17 3 "vertexPosition_modelspace" 0  -- vertex location
    setAttrib 17 3 "vertexNormal" 3  -- vertex normal
    setAttrib 17 2 "vertexUV" 6  -- vertex UV
    setAttrib 17 3 "vertex_col" 8  -- vertex color
    setAttrib 17 3 "vertex_tangent" 11 -- vertex tangent
    setAttrib 17 3 "vertex_bitangent" 14 -- vertex bitangent

    GL.bindVertexArrayObject $= Nothing
    return $ Mesh verts indices vao vbo ebo shad qZero mtex norm
  where
    setAttrib size attrSize name offset = do
      let glFloatSize = sizeOf (undefined :: GL.GLfloat)
          glLocation  = fromIntegral $ size * glFloatSize
          glOffset    = intPtrToPtr $ fromIntegral(offset * glFloatSize)
      loc@(GL.AttribLocation n) <- GL.get $ GL.attribLocation (shad^.program) name
      unless (n > 1000000) $ do
        GL.vertexAttribPointer loc $=
          (GL.ToFloat,
           GL.VertexArrayDescriptor attrSize GL.Float glLocation glOffset)
        GL.vertexAttribArray loc $= GL.Enabled

sendData :: forall a. VS.Storable a => GL.BufferTarget -> VS.Vector a -> IO ()
sendData t d =
  VS.unsafeWith d $
    \vptr -> GL.bufferData t $=
               (fromIntegral $ VS.length d * sizeOf (undefined :: a),
                vptr,
                GL.StaticDraw)

createAndBindArrayBuffer
  :: forall a. VS.Storable a =>
  GL.BufferTarget
  -> VS.Vector a
  -> IO GL.BufferObject
createAndBindArrayBuffer arrayType arrayData = do
    bufferObject <- GL.genObjectName
    GL.bindBuffer arrayType $= Just bufferObject
    sendData arrayType arrayData
    return bufferObject

vertexBufferData :: (VS.Vector Float, VS.Vector GL.BaseInstance, [VS.Vector Float])
vertexBufferData =
  let v = --position        normal         UV        color          tangents
          [-2.0, 0.0, -2.0, 0.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.0, 1.0, 0.1, 0.0, 0.0, 0.0, 0.0, 1.0,
            2.0, 0.0, -2.0, 0.0, 1.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.1, 0.0, 0.0, 0.0, 0.0, 1.0,
           -2.0, 0.0,  2.0, 0.0, 1.0, 0.0, 0.0, 1.0, 0.0, 0.0, 1.0, 0.1, 0.0, 0.0, 0.0, 0.0, 1.0,
            2.0, 0.0,  2.0, 0.0, 1.0, 0.0, 1.0, 1.0, 0.0, 0.0, 1.0, 0.1, 0.0, 0.0, 0.0, 0.0, 1.0]
      v3 = [[-2.0, 0.0, -2.0],
            [ 2.0, 0.0, -2.0],
            [-2.0, 0.0,  2.0],
            [ 2.0, 0.0,  2.0]]
      i = [0,1,2,1,3,2]
  in (v,i,v3)

flatQuad shad tex norm =
  createMesh vertexBufferData shad (Just tex) (Just norm)

update :: (Float -> Float -> Bool) -> Int -> Float -> Vector Float -> Vector Float
update pred ix f v = if pred f (v VS.! ix) then VS.update_ v [ix] [f] else v

updatePair pred ix f = update pred ix f *** update ((not .) . pred) ix f

-- getAABB :: Mesh -> (Vector Float, Vector Float)
-- getAABB = VS.ifoldr inserter ([0,0,0],[0,0,0]) . view vertices
--   where inserter ix = case mod ix 17 of
--           1 -> updatePair (<) 0
--           2 -> updatePair (<) 1
--           3 -> updatePair (<) 2
--           _ -> flip const

max_stars_repo_name: Antystenes/CPG

max_issues_repo_name: Antystenes/CPG

max_forks_repo_name: Antystenes/CPG


text:
{-# LANGUAGE BangPatterns #-}
{- |
Module      : ML.NN
Description : Simple neural network implementation, for education purposes only.
-}
module ML.NN
       (
           -- * Data types
           ActivationFunction  -- Re-export from NN.ActivationFunction.
       ,   Layer(..)
       ,   Network(..)

           -- * Network initialization
       ,   randLayer
       ,   randNetwork

           -- * Running networks
       ,   feedForward
       ,   runNetwork
       ,   feedForwardSet
       ,   runNetworkSet
       ) where

import           ML.NN.ActivationFunction (ActivationFunction)

import           Control.Monad (forM, replicateM)
import           Control.Monad.Random (Rand, liftRand)
import           Data.Foldable (foldl')
import           Data.Random.Normal (normal)
import           Numeric.LinearAlgebra (Matrix, R, Vector, (><), (<>), (#>), cmap,
                                        fromColumns, vector)
import           System.Random (RandomGen)

-- ==================================================
-- Types.
-- ==================================================

-- | A layer in a neural network is a bias vector and weight matrix.
--
-- Let /n/ be the number of neurons in the layer and /m/ be the number
-- of inputs to the layer. Then 'layerBiases' is a vector in Rⁿ and
-- 'layerWeights' is an /nxm/ real matrix.
data Layer = Layer
             { layerBiases  :: {-# UNPACK #-} !(Vector R)
                                              -- ^ A vector in Rⁿ representing the neuron biases.
             , layerWeights :: {-# UNPACK #-} !(Matrix R)
                                              -- ^ An /nxm/ real matrix of the neuron weights.
             } deriving (Show, Read)

-- | A network is a list of layers.
data Network = Network
               { networkLayers :: [Layer]
               } deriving (Show, Read)

-- ==================================================
-- Network initialization.
-- ==================================================

-- | Generate a random neural network given the size of each layer.
--
-- For example, @[3,2,4]@ will generate a neural network with 3 input
-- neurons, 1 hidden layer with 2 neurons and 4 output neurons.
randNetwork :: RandomGen g => [Int] -> Rand g Network
randNetwork sizes = Network <$> forM dims (uncurry randLayer)
    where dims = adjacentPairs sizes

-- | Return a list of pairs of adjacent elements in a list.
--
-- Example: adjacentPairs [1,2,3] ==> [(1,2), (2,3)]
adjacentPairs :: [a] -> [(a,a)]
adjacentPairs xs = zip (init xs) (tail xs)

-- | Generate a randomly initialized layer in a neural network.
randLayer :: RandomGen g
             => Int           -- ^ Number of inputs into the layer.
             -> Int           -- ^ Number of neurons in the layer.
             -> Rand g Layer  -- ^ Randomly generated layer.
randLayer numInputs numNeurons = do
    bias <- vector <$> replicateM numNeurons (liftRand normal)
    weights <- (numNeurons><numInputs) <$> replicateM (numNeurons*numInputs) (liftRand normal)
    return $ Layer bias weights

-- ==================================================
-- Running networks.
-- ==================================================

-- | Feed the output from a previous layer to the next layer.
feedForward :: ActivationFunction  -- ^ Neuron activation function.
            -> Vector R            -- ^ Input to the layer.
            -> Layer               -- ^ Layer to run.
            -> Vector R            -- ^ Output from the layer.
feedForward act x (Layer biases weights) = cmap act z
    where z = (weights #> x) + biases

-- | Run a neural network.
runNetwork :: Network             -- ^ Network to run.
           -> ActivationFunction  -- ^ Neuron activation function.
           -> Vector R            -- ^ Network input.
           -> Vector R            -- ^ Network output.
runNetwork (Network layers) act input = foldl' (feedForward act) input layers

feedForwardSet :: ActivationFunction -> Matrix R -> Layer -> Matrix R
feedForwardSet act xM (Layer biases weights) = cmap act z
    where z = (weights <> xM) + fromColumns [biases]

runNetworkSet :: Network -> ActivationFunction -> Matrix R -> Matrix R
runNetworkSet (Network layers) act input = foldl' (feedForwardSet act) input layers

max_stars_repo_name: m-renaud/ML

max_issues_repo_name: m-renaud/ML

max_forks_repo_name: m-renaud/ML


text:
{-|
  Copyright   :  (C) 2019, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Clash.Class.AutoReg.Instances where

import           Clash.Class.AutoReg.Internal
import           Clash.CPP                           (maxTupleSize)

#if MIN_VERSION_base(4,12,0)
import           Data.Complex (Complex)
import           Data.Ord (Down)
#endif

import           Data.Ratio (Ratio)

#if MIN_VERSION_base(4,12,0)
deriveAutoReg ''Complex
deriveAutoReg ''Down
#endif

deriveAutoReg ''Ratio

deriveAutoRegTuples [2..maxTupleSize]

max_stars_repo_name: JvWesterveld/clash-compiler


text:
module Q.Options.Black76
  (
    Black76(..)
  , atmf
  , euOption
  , eucall
  , euput
  , dPlus
  , dMinus
  )
  where

import           Numeric.GSL (derivCentral)
import           Q.Options (DF, Delta (Delta), Forward (..), Gamma (Gamma), OptionType (..),
                            Premium (Premium), Strike (..), TimeScaleable (scale), TotalVar (..),
                            Valuation (Valuation, vPremium), Vega (Vega), Vol (..),
                            YearFrac (YearFrac), discount)
import           Q.Options.ImpliedVol.TimeSlice (TimeSlice (..))
import           Statistics.Distribution (cumulative, density)
import           Statistics.Distribution.Normal (standard)
import Q.Types (LogRelStrike)

data Black76 = Black76 {
    b76F   :: Forward
  , b76DF  :: DF
  , b76T   :: YearFrac
  , b76Vol :: Vol
}

-- | At the money forward strike.
atmf :: Black76 -> Strike
atmf Black76{..} = Strike f
  where (Forward f) = b76F

-- | European option valuation with black 76
euOption :: Black76 -> OptionType -> Strike -> Valuation
euOption Black76{..} cp k = Valuation premium delta vega gamma where
  (Forward f) = b76F
  n           = cumulative standard
  (Vol sigmaSqt) = scale b76T b76Vol
  d1          = dPlus  b76F b76Vol k b76T
  d2          = dMinus b76F b76Vol k b76T
  nd1         = n d1
  nd2         = n d2
  callDelta   = b76DF `discount` nd1
  putDelta    = b76DF `discount` (- (n (-d1)))
  vega        = Vega  $ b76DF `discount` density standard d1 * f * sigmaSqt
  gamma       = Gamma $ b76DF `discount` density standard d1 / (f * sigmaSqt)
  premium  = Premium $ case cp of
    Call -> b76DF `discount` (f * nd1 - nd2 * k')
    Put  -> b76DF `discount` (n (-d2) * k' - n (-d1) * f)
    where (Strike k') = k
  delta | cp == Call = Delta callDelta
        | otherwise = Delta putDelta

-- | see 'euOption'
euput :: Black76 -> Strike -> Valuation
euput b76 =  euOption b76 Put

-- | see 'euOption'
eucall :: Black76 -> Strike -> Valuation
eucall b76 = euOption b76 Call

dPlus :: Forward -> Vol -> Strike -> YearFrac -> Double
dPlus (Forward f) (Vol sigma) (Strike k) (YearFrac t) =
  recip (sigma * sqrt t) * (log (f/k) + 0.5 * sigma * sigma * t)

dMinus :: Forward -> Vol -> Strike -> YearFrac -> Double
dMinus (Forward f) (Vol sigma) (Strike k) (YearFrac t) =
  recip (sigma * sqrt t) * (log (f/k) - 0.5 * sigma * sigma * t)

instance TimeSlice Black76 Strike where
  totalVar Black76{..} _ = TotalVar $ vol * vol * t
    where (Vol vol) = b76Vol
          (YearFrac t) = b76T
  dW _ _  = 0
  d2W _ _ = 0

  impliedDensity b76 (Strike k) = let
    dk k' = fst (derivCentral 1e-4 (\k2 -> let (Premium v) = vPremium (eucall b76 (Strike k2)) in v) k')
    in fst (derivCentral 1e-4 dk k)

instance TimeSlice Black76 LogRelStrike  where
  totalVar Black76{..} _ = TotalVar $ vol * vol * t
    where (Vol vol) = b76Vol
          (YearFrac t) = b76T
  dW _ _  = 0
  d2W _ _ = 0

  impliedDensity bs k = impliedDensity f k where
    f :: LogRelStrike  -> TotalVar
    f = totalVar bs

max_stars_repo_name: ghais/HQu

max_issues_repo_name: ghais/HQu

max_forks_repo_name: ghais/HQu