penrose 0.1.0.2 → 0.1.1.0
raw patch · 34 files changed
+12379/−3786 lines, 34 filesdep +ansi-terminaldep +arraydep +bytestringdep −glossdep ~addep ~aesondep ~basesetup-changed
Dependencies added: ansi-terminal, array, bytestring, directory, docopt, extra, hmatrix, hslogger, http-types, mtl, multimap, network, parser-combinators, pretty, pretty-show, pretty-terminal, process, random-shuffle, scotty, split, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, unordered-containers, uuid
Dependencies removed: gloss
Dependency ranges changed: ad, aeson, base, containers, megaparsec, old-time, random, text, websockets
Files
- README.md +57/−85
- Setup.hs +0/−3
- penrose.cabal +144/−25
- src/Compiler.hs +0/−491
- src/Element.hs +417/−0
- src/Env.hs +555/−0
- src/Functions.hs +1676/−335
- src/GenOptProblem.hs +1228/−0
- src/Interface.hs +130/−0
- src/Main.hs +4/−79
- src/Optimizer.hs +510/−0
- src/Plugins.hs +102/−0
- src/Runtime.hs +0/−1828
- src/Serializer.hs +127/−0
- src/Server.hs +544/−93
- src/ShadowMain.hs +111/−0
- src/Shapes.hs +1439/−410
- src/StyAst.hs +0/−421
- src/Style.hs +1536/−0
- src/Substance.hs +787/−0
- src/SubstanceJSON.hs +202/−0
- src/SubstanceTokenizer.hs +994/−0
- src/SubstanceTokenizer.x +87/−0
- src/Sugarer.hs +173/−0
- src/Tokenizer.hs +166/−0
- src/Transforms.hs +690/−0
- src/Utils.hs +316/−16
- test/Functions/Tests.hs +41/−0
- test/Server/Tests.hs +27/−0
- test/ShadowMain/Tests.hs +75/−0
- test/Shapes/Tests.hs +38/−0
- test/TestSuite.hs +38/−0
- test/Transforms/Tests.hs +131/−0
- test/Utils/Tests.hs +34/−0
README.md view
@@ -1,98 +1,70 @@-# Penrose--We're building a prototype for set theory. Not ready for contributions or public use yet, but hopefully will be after this summer! See penrose.ink for more information.--------### Usage--Install any relevant packages: `cabal install $PACKAGE_NAME` (though I'm told the Haskell community has moved on to the better `stack` package manager).--To compile both:-`ghc Runtime.hs`--To just compile Compiler:-`ghc Compiler.hs`--To use:-`./Runtime <filename>.sub <filename>.sty`--User interface:-* You can click and drag the objects, including labels. The optimization will pause while dragging and re-layout when the mouse is lifted. The object on top is semi-arbitrary, decided by the order of the objects in the internal list.-* Pressing the `R` key will resample the configuration. -* Pressing the `A` key will turn autostep (automatically stepping the optimization) on or off. -* Pressing the `S` key will step the optimization by one step if autostep is off. It won't do anything if autostep is on.--Examples of existing pairs:-* twosets.sub settheory.sty-* continuousmap1.sub continuousmap1.sty (system doesn't currently handle this)--------### Organization--`src` contains the compiler and runtime.--`src/GC-slides` contains slides from weekly group meetings.--`src/gifs` and `src/pictures` contain GIFs and pictures documenting new features in the system.--Other directories in the root contain documentation and old parts of the system.--------### More information--I use the following library to handle the graphics, animation, and user input: [gloss](https://hackage.haskell.org/package/gloss-1.10.2.3/docs/Graphics-Gloss-Interface-Pure-Game.html).--Functionality of the current code:--* gradient-descent-based layout -* with backtracking line search -* for set theory with points, sets, and certain constraints on points and sets-* with very simple objective functions provided (e.g. centering)-* where the layout is animated and interactive (v. useful for debugging)+# Penrose [](https://circleci.com/gh/penrose/penrose/tree/master) -Some limitations: +**Penrose is an early-stage system that is still in development.** Our system is not ready for contributions or public use yet, but hopefully will be soon. Send us an email if you're interested in collaborating. -* line search sometimes doesn't terminate-* need a better debugging interface for optimization, e.g. live parameter tuning+* See [the site](http://www.penrose.ink/) for more information and examples. +* See the [wiki](https://github.com/penrose/penrose/wiki) for more system-specific information on building, running, testing, and debugging the system. +* For even more documentation, see Nimo Ni's [README](https://github.com/wodeni/notes-public/blob/master/penrose/archive/ramp-down.md). -Parameters: +### Example -* stepsPerSecond: number of simulation steps for `gloss` to take for each second of real time-* picWidth, picHeight: canvas dimensions-* stepFlag: turns stepping the simulation on and off for debugging (no stepping = objects don't move)-* clampFlag: turns clamping gradient values on and off for debugging-* debug: turns on/off the debug print functions-* constraintFlag: turns constraint satisfaction on/off (currently off because we're doing unconstrained optimization)-* Default ambient objective functions are specified in `ambientObjFns`, and analogously for `ambientConstrFns`.-* Default objective functions are specified in `genObjsAndFns`.-* btls: turn on/off the backtracking line search for debugging (off = use a fixed timestep specified in the code)-* alpha and beta: parameters for the backtracking line search (see code for a more detailed description)-* stopEps: stopping condition sensitivity for gradient descent. Stop when magnitude of gradient is less than stopEps.+Here's a simple Penrose visualization in the domain of set theory. -Debugging:+<img src="https://i.imgur.com/3JHZeaX.png" width=300> -* Use the flags above.-* I also use `ghci`, the Haskell REPL. To load the file, do `:l filename.hs`. To import a library, paste in the normal import statement. To declare something, start with a `let` statement, e.g. `let x = 5`.-* For printing internal values, I use the [Debug.Trace](https://hackage.haskell.org/package/base-4.9.0.0/docs/Debug-Trace.html) library.+It's specified by the following Substance and Style programs. ------ -### Design+- `tree.sub`+ ```+ Set A+ Set B+ Set C+ Set D+ Set E+ Set F+ Set G+ Subset B A+ Subset C A + Subset D B+ Subset E B+ Subset F C+ Subset G C+ NoIntersect E D+ NoIntersect F G+ NoIntersect B C+ ```+- `venn.sty`+ ```+ Set x {+ shape = Circle { }+ constraint contains(x, x.label)+ } -* Compiler parses the Substance and Style programs and combines their abstract syntax trees into Layout (the intermediate layout representation).-* Runtime calls Compiler on the input files, and transforms the data in Layout to Opt (the representations used by the optimization code).-* Runtime imports Compiler as a module.+ Intersect x y {+ constraint overlapping(x, y)+ constraint outsideOf(y.label, x)+ constraint outsideOf(x.label, y)+ } -----+ NoIntersect x y {+ constraint nonOverlapping(x, y)+ } -### Usage for old code+ Subset x y {+ constraint contains(y, x)+ constraint smallerThan(x, y)+ constraint outsideOf(y.label, x)+ } -Compile: `ghc settheory.hs`+ NoSubset x y {+ objective repel(x, y)+ constraint outsideOf(x, y)+ constraint outsideOf(y.label, x)+ constraint outsideOf(x.label, y)+ constraint nonOverlapping(x, y)+ }+ ``` -Create SVG: `./settheory -w 500 -h 500 -o set.svg`-(The parameters are the width and height of the rendered picture.)+Here's how the optimization looks live in the UI. -Open SVG: `chrome set.svg`+<img src="https://github.com/penrose/penrose/blob/master/assets/penrose_readme.gif?raw=true" width=500>
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
penrose.cabal view
@@ -1,29 +1,148 @@--- Initial penrose.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/--name: penrose-version: 0.1.0.2-synopsis: A system that automatically visualize mathematics--- description: -homepage: http://penrose.ink-license: MIT-license-file: LICENSE-author: team-penrose-maintainer: kqy@cs.cmu.edu--- copyright: --- category: -build-type: Simple-extra-source-files: ChangeLog.md, README.md-cabal-version: >=1.10+cabal-version: >=1.10+name: penrose+version: 0.1.1.0+license: MIT+license-file: LICENSE+maintainer: penrose.team@gmail.com+author: team-penrose+homepage: http://penrose.ink+synopsis: Create beautiful diagrams just by typing mathematical notation in plain text.+build-type: Simple+extra-source-files:+ ChangeLog.md+ README.md+ test/TestSuite.hs source-repository head- type: git- location: https://github.com/ghcjs/ghcjs.git+ type: git+ location: https://github.com/penrose/penrose.git executable penrose- main-is: Main.hs- other-modules: Utils Server StyAst Compiler Functions Runtime Shapes- other-extensions: AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction, OverloadedStrings, DeriveGeneric, DuplicateRecordFields- build-depends: base >=4.9 && <4.10, random >=1.1 && <1.2, containers >=0.5 && <0.6, gloss >=1.11 && <1.12, megaparsec >=5.3 && <5.4, ad >=4.3 && <4.4, aeson >=1.2 && <1.3, text >=1.2 && <1.3, websockets >=0.11 && <0.12, old-time >=1.1 && <1.2- hs-source-dirs: src- default-language: Haskell2010+ main-is: Main.hs+ hs-source-dirs: src+ build-tools: alex+ other-modules:+ ShadowMain+ Utils+ Plugins+ Server+ Substance+ SubstanceJSON+ Element+ Env+ Style+ Optimizer+ GenOptProblem+ Shapes+ Functions+ Transforms+ SubstanceTokenizer+ Sugarer+ Interface+ Tokenizer+ Serializer+ default-language: Haskell2010+ other-extensions: AllowAmbiguousTypes RankNTypes UnicodeSyntax+ NoMonomorphismRestriction OverloadedStrings DeriveGeneric+ DuplicateRecordFields+ build-depends:+ base -any,+ random -any,+ random-shuffle -any,+ containers -any,+ megaparsec -any,+ ad -any,+ aeson -any,+ text -any,+ websockets -any,+ old-time -any,+ pretty -any,+ pretty-show -any,+ extra -any,+ process -any,+ network -any,+ uuid -any,+ hslogger -any,+ split -any,+ multimap -any,+ directory -any,+ unordered-containers -any,+ pretty-terminal -any,+ scotty -any,+ http-types -any,+ mtl -any,+ bytestring -any,+ array -any,+ ansi-terminal -any,+ docopt -any,+ parser-combinators -any,+ hmatrix -any++test-suite penrose-testsuite+ type: exitcode-stdio-1.0+ main-is: TestSuite.hs+ hs-source-dirs: src test+ other-modules:+ ShadowMain+ Utils+ Plugins+ Server+ Substance+ Interface+ Serializer+ SubstanceJSON+ Element+ Env+ Style+ GenOptProblem+ Optimizer+ Functions+ Transforms+ Shapes+ SubstanceTokenizer+ Sugarer+ Tokenizer+ ShadowMain.Tests+ Server.Tests+ -- Substance.Tests+ -- Style.Tests+ Utils.Tests+ Functions.Tests+ Shapes.Tests+ Transforms.Tests+ default-language: Haskell2010+ build-depends:+ base >=4.9 && <4.10,+ random >=1.1 && <1.2,+ random-shuffle >=0.0.4 && <0.1,+ containers >=0.5 && <0.6,+ megaparsec >=6.4 && <6.5,+ ad >=4.3 && <4.4,+ aeson >=1.2 && <1.3,+ text >=1.2 && <1.3,+ websockets >=0.11 && <0.12,+ old-time >=1.1 && <1.2,+ pretty >=1.1.3 && <1.2,+ extra >=1.6 && <1.7,+ process >=1.4.3 && <1.5,+ network >=2.6.3 && <2.7,+ pretty-show -any,+ split -any,+ tasty -any,+ tasty-smallcheck -any,+ tasty-quickcheck -any,+ tasty-hunit -any,+ directory -any,+ multimap -any,+ pretty-terminal -any,+ scotty -any,+ http-types -any,+ mtl -any,+ bytestring -any,+ ansi-terminal -any,+ array -any,+ uuid -any,+ hslogger -any,+ docopt -any,+ parser-combinators -any,+ hmatrix -any
− src/Compiler.hs
@@ -1,491 +0,0 @@- module Compiler where--- TODO split this up + do selective export--import System.IO -- read/write to file-import System.Environment-import Control.Arrow ((>>>))-import System.Random-import Debug.Trace-import Data.List---- Substance grammar--data SetType = Open | Closed | Unspecified- deriving (Show, Eq)--data Set = Set' String SetType- deriving (Show, Eq)--data Pt = Pt' String- deriving (Show, Eq)---- Map <label> <from-set> <to-set>-data Map = Map' String String String -- TODO needs validation vs Set Set- deriving (Show, Eq)--data SubObj = OS Set | OP Pt | OM Map- deriving (Show, Eq)--- TODO open sets?? they should inherit style characteristics from sets--data SubObjType = Set SetType | Pt | Map -- how to tie this to the types above- deriving (Show, Eq)--data SubDecl = Decl SubObj- deriving (Show, Eq)---- TODO vs. Set Set. user only specifies names--- TODO we assume that non-subset sets must not overlap (implicit constraint)-data SubConstr = Intersect String String- | NoIntersect String String- | Subset String String- | NoSubset String String- | PointIn String String- | PointNotIn String String- deriving (Show, Eq)--data SubLine = LD SubDecl | LC SubConstr- deriving (Show, Eq)--- TODO do some program analysis to split the decls and constraints, which refer to things in the decls--- and validate that the things they refer to are the right type (inline at some point??)--type SubSpec = [SubLine]-type SubSpecDiv = ([SubDecl], [SubConstr])---- Sample Substance programs (more in file)-sub0 = "Set A"-sub1 = "OpenSet A"-sub2 = "Set A\nOpenSet B"-sub3 = "Set A\nOpenSet B\nSubset A B"---- test-subSpecs = [sub0, sub1, sub2, sub3]-subTest = subValidateAll subSpecs---- specs for 3 continuous map diagrams can be found in continuousmap1.sub, etc.---- Substance parser--- TODO divide into decls and constraints for typechecking and reference checking--- parsing human-written programs: extra spaces ok (words removes them).--- extra newlines ok (filter empty lines out). HOWEVER, this is not ok for validation, as--- the pretty-printer does not add additional whitespace.-subParse :: String -> SubSpec-subParse = map (subToLine . words) . filter nonempty . lines- where nonempty x = (x /= "")---- parses based on line length. should really tokenize and behave like DFA--- TODO fix this or use lexer / parser generator-subToLine :: [String] -> SubLine-subToLine s@[x, y] = LD $ Decl $- if x == "Set" then OS (Set' y Unspecified)- else if x == "OpenSet" then OS (Set' y Open)- else if x == "ClosedSet" then OS (Set' y Closed)- else if x == "Point" then OP (Pt' y)- else error $ "Substance spec line: 2-token line '"- ++ show s ++ "' does not begin with Set/OpenSet/ClosedSet"---- TODO validate names exist in decls, are of type set--- TODO auto-gen parser from grammar-subToLine s@[x, y, z] = LC $- if x == "Intersect" then Intersect y z- else if x == "NoIntersect" then NoIntersect y z- else if x == "Subset" then Subset y z- else if x == "NoSubset" then NoSubset y z- else if x == "In" then PointIn y z -- TODO ^- else if x == "NotIn" then PointNotIn y z- else error $ "Substance spec line: 3-token line '"- ++ show s ++ "' does not begin with (No)Intersect/Subset/(Not)In"--subToLine s@[w, x, y, z] = LD $ Decl $- if w == "Map" then OM (Map' x y z)- else error $ "Substance spec line: 4-token line '"- ++ show s ++ "' does not begin with Map"--subToLine s = error $ "Substance spec line '" ++ show s ++ "' is not 2, 3, or 4 tokens"---- Pretty-printer for Substance AST-subPrettyPrintLine :: SubLine -> String-subPrettyPrintLine (LD (Decl decl)) = case decl of- OS (Set' name stype) -> case stype of- Open -> "OpenSet " ++ name- Closed -> "ClosedSet " ++ name- Unspecified -> "Set " ++ name- OP (Pt' name) -> "Point " ++ name- OM (Map' x y z) -> "Map " ++ x ++ " " ++ y ++ " " ++ z-subPrettyPrintLine (LC constr) = case constr of- Subset s1 s2 -> "Subset " ++ s1 ++ " " ++ s2- PointIn p s -> "In " ++ p ++ " " ++ s- PointNotIn p s -> "NotIn " ++ p ++ " " ++ s--subPrettyPrint :: SubSpec -> String-subPrettyPrint s = concat $ intersperse nl $ map subPrettyPrintLine s---- Ugly pretty-printer for Substance-subPrettyPrintLine' :: SubLine -> String-subPrettyPrintLine' = show--subPrettyPrint' :: SubSpec -> String-subPrettyPrint' s = concat $ intersperse nl $ map subPrettyPrintLine' s---- if a well-formed program is parsed, its output should equal the original-subValidate :: String -> Bool-subValidate s = (s == (subPrettyPrint $ subParse s))--subValidateAll :: [String] -> Bool-subValidateAll = all subValidate---- Substance reference checker TODO--- returns lines in same order as in program-subSeparate :: SubSpec -> SubSpecDiv-subSeparate = foldr separate ([], [])- where separate line (decls, constrs) =- case line of- (LD x) -> (x : decls, constrs)- (LC x) -> (decls, x : constrs)---- Substance typechecker TODO--------------------------------------------- Style grammar (relies on the Substance grammar, specifically SubObj)--- no styling for constraints--data SetShape = SetCircle | Box- deriving (Show, Eq)--data PtShape = SolidDot | HollowDot | Cross- deriving (Show, Eq)---- data MapShape = LeftArr | RightArr | DoubleArr-data MapShape = SolidArrow- deriving (Show, Eq)--data Direction = Horiz | Vert | Angle Float- deriving (Show, Eq)--data SubShape = SS SetShape | SP PtShape | SM MapShape- deriving (Show, Eq)--data LineType = Solid | Dotted- deriving (Show, Eq, Read)--data Color = Red | Blue | Black | Yellow -- idk- deriving (Show, Eq, Read)--data M a = Auto | Override a -- short for Maybe (option type)- deriving (Show, Eq)--data StyLevel = SubVal String | LabelOfSubVal String | SubType SubObjType | Global- deriving (Show, Eq)--- LabelOfSubObj is meant to allow styling of whatever label object A (originally named A) now has--- e.g. it could be named "hello" with Label (SubValue "A") (Override "Hello"). (don't label labels)--- then do (Position (LabelOfSubObj "A") 100 200)--type Opacity = Float -- 0 to 100%, TODO validate-type Priority' = Float -- higher = higher priority---- There are three different layers of Style: global setting (over all types),--- type setting (over all values of that type), and value setting.--- The more specific ones implicitly override the more general ones.--- If there are two conflicting ones at the same level, the more recent one will be used for "everything"--- TODO more sophisticated system with scope--- TODO if some aspect of style unspecified, then supplement with default--- any setting is implicitly an override of the global default style--- can choose to leave out an aspect (= implicitly auto), or explicitly specify auto; same thing--- TODO need to validate that the shape specified matches that of the type--- e.g. Shape Map Diamond is invalid--- also, order does not matter between lines-data StyLine = Shape StyLevel (M SubShape) -- implicitly solid unless line is specified- | Line StyLevel (M LineType) (M Float) -- hollow shape; non-negative thickness- | Color StyLevel (M Color) (M Opacity)- | Priority StyLevel (M Priority') -- for line breaking- | Dir StyLevel (M Direction)- | Label StyLevel (M String) -- TODO add ability to turn off labeling- | Scale StyLevel (M Float) -- scale factor- | AbsPos StyLevel (M (Float, Float)) -- in pixels; TODO relative positions- deriving (Show, Eq)--type StySpec = [StyLine]---- Sample Style programs and tests--- TODO style is more complicated than substance; this doesn't test it fully--nl = "\n"-together = intercalate nl-sty0 = "Shape Global Circle"-sty1 = "Shape Set Box"-sty2 = "Shape A Circle"-sty3 = together [sty0, sty1, sty2] -- test overrides-sty4 = "Shape Set Circle\nShape Map RightArr\nLine Map Solid"-sty5 = "Line Map Dotted 5.01"-sty6 = "Color All Red 66.7"-sty7 = "Priority Label_AB 10.1"-sty8 = "Label All hithere"-sty9 = "Label Label_AB oh_no" -- TODO don't label labels. also allow spaces in labels (strings)-sty10 = "Direction Map Horizontal"--- test all-sty_all = "Shape Set Circle\nShape Map RightArrow\nLine Map Solid Auto\nColor Global Blue 100\nPriority Map 100\nPriority Set 50\nDirection Map Horizontal\nDirection A Vertical\nLabel A NewA\nScale A 100\nPosition A -100 501\nColor Label_A Blue 100"--- TODO deal with OpenSet, ClosedSet--- TODO write tests of substance working *with* style---- TODO add tests that should fail-styf1 = "Shape"-styf2 = "Shape Label_A"-styf3 = "Line Dotted 5.01"---- TODO syntactically valid but semantically invalid programs-styfs1 = "Shape Map Circle"---- Style parser-styParse :: String -> StySpec -- same as subParse-styParse = map (styToLine . words) . filter nonempty . lines- where nonempty x = (x /= "")--getLevel :: String -> StyLevel-getLevel s = if s == "All" then Global- -- TODO will need to update parsers whenever I add a new type...- else if s == "Set" then SubType (Set Unspecified)- else if s == "OpenSet" then SubType (Set Open)- else if s == "ClosedSet" then SubType (Set Closed)- else if s == "Point" then SubType Pt- else if s == "Map" then SubType Map- else if (take 6 s == "Label_")- then let res = drop 6 s in- if length res > 0 then LabelOfSubVal res- else error "Empty object name ('Label_') in style level"- else SubVal s -- sets could be named anything; later we validate that this ref exists--getShape :: [String] -> M SubShape-getShape [] = error "No Style shape param"-getShape [x] = if x == "Auto" then Auto- else if x == "Circle" then Override (SS SetCircle)- else if x == "Box" then Override (SS Box)- else if x == "SolidDot" then Override (SP SolidDot)- else if x == "HollowDot" then Override (SP HollowDot)- else if x == "Cross" then Override (SP Cross)- else if x == "SolidArrow" then Override (SM SolidArrow)- -- else if x == "LeftArrow" then Override (SM LeftArr)- -- else if x == "RightArrow" then Override (SM RightArr)- -- else if x == "DoubleArrow" then Override (SM DoubleArr)- else error $ "Invalid shape param '" ++ show x ++ "'"-getShape s = error $ "Too many style shape params in '" ++ show s ++ "'"--handleAuto :: String -> (String -> a) -> M a-handleAuto v f = if v == "Auto" then Auto else Override (f v)--readFloat :: String -> Float-readFloat x = read x :: Float--styToLine :: [String] -> StyLine-styToLine [] = error "Style spec line is empty"-styToLine s@[x] = error $ "Style spec line '" ++ show s ++ "' is only 1 token"-styToLine s@(x : y : xs) =- let level = getLevel y in -- throws its own errors- if x == "Shape" then- let shp = getShape xs in -- TODO handle Auto- Shape level shp- else if x == "Line" then- case xs of- [a, b] -> let ltype = handleAuto a (\x -> read x :: LineType) in -- TODO read is hacky, bad errorsn- let lthick = handleAuto b readFloat in- Line level ltype lthick- _ -> error $ "Incorrect number of params (not 3) for Line: '" ++ show xs ++ "'"- else if x == "Color" then- case xs of- [a, b] -> let ctype = handleAuto a (\x -> read x :: Color) in- let opacity = handleAuto b readFloat in- Color level ctype opacity- _ -> error $ "Incorrect # of params (not 3) for Color: '" ++ show xs ++ "'"- else if x == "Priority" then- case xs of- [a] -> let priority = handleAuto a readFloat in- Priority level priority- _ -> error $ "Incorrect number of params (not 2) for Priority: '" ++ show xs ++ "'"- else if x == "Direction" then- case xs of- [a] -> let dir = handleAuto a (\x -> if x == "Horizontal" then Horiz- else if x == "Vertical" then Vert- else Angle (read x :: Float)) in- Dir level dir- _ -> error $ "Incorrect number of params (not 2) for Direction: '" ++ show xs ++ "'"- else if x == "Label" then- case xs of- [a] -> Label level (handleAuto a id) -- label name is a string- _ -> error $ "Incorrect number of params (not 2) for Label: '" ++ show xs ++ "'"- else if x == "Scale" then- case xs of- [a] -> let scale = handleAuto a readFloat in- Scale level scale- _ -> error $ "Incorrect number of params (not 2) for Scale: '" ++ show xs ++ "'"- else if x == "Position" then- case xs of- [a] -> if a == "Auto" then AbsPos level Auto- else error $ "Only 1 param, but it is not Auto: '" ++ show a ++ "'"- [a, b] -> let x' = readFloat a in -- no Auto allowed if two params- let y' = readFloat b in- AbsPos level (Override (x', y'))- _ -> error $ "Incorrect number of params (not 2) for Position: '" ++ show xs ++ "'"- else error $ "Style spec line: '" ++ show s- ++ "' does not begin with Shape/Line/Color/Priority/Direction/Label/Scale/Position"---- Pretty-printer for Style AST--- TODO write the full pretty-printer-styPrettyPrintLine :: StyLine -> String-styPrettyPrintLine = show--styPrettyPrint :: StySpec -> String-styPrettyPrint s = concat $ intersperse nl $ map styPrettyPrintLine s---- Style validater---- Style typechecker TODO---- Style reference checker--------------------------------------------- Take a Substance and Style program, and produce the abstract layout representation---- TODO try doing this w/o Style first? everything is compiled to a default style with default labels--- write out applying Style on top: applying global overrides, then by type, then by name--- going to need some kind of abstract intermediate type--- figure out the intermediate subsets of the language I can support- -- e.g. map requires me to draw arrows, don't support direction and priority for now--- how many objects I can support, e.g. A -> B -> C -> D requires scaling the size of each obj to fit on canvas--- how the optimization code needs to scale up to meet the needs of multiple objects (labels only?)--- also, optimization on multiple layouts--- how to lay things out w/ constraints only (maybe)--- how to apply optimization to the labels & what their obj functions should be---- TODO finish parser for both, put into Slack tonight w/ description of override, continuousmap1.sub/sty---- Substance only, circular sets only -> world state--- then scale up optimization code to handle any number of sets--- then support the Subset constraint only--- then add labels and set styles-subt1 = "Set A"-subt2 = "Set A\nSet B"-subt2a = "Set A\nSet B\nSubset A B"-subt3 = "Set A\nSet B\nSet C"-subt4 = "Set A\nSet B\nSet C"-subt4a = "Set A\nSet B\nOpenSet C"-subt5 = "Set A\nSet B\nOpenSet C\nSubset B C"-styt1 = "Color Set Blue 50"-styt2 = "Color Set Blue 50\nLine OpenSet Dotted 1"---- New type: inner join (?) of Decl with relevant constraint lines and relevant style lines--- (only the ones that apply; not the ones that are overridden)--- Type: Map Var (Decl, [SubConstr], [StyLine]) <-- the Var is the object's name (string) in Substance--- does this include labels?? it includes overridden labels in StyLine but not labels like Set A -> "A"--- for now, assume what about labels? -- are they separate? should they be linked? they all get default style- -- make a separate Map Label ObjName ? no, assuming no renaming for now--- then we need to write a renderer type: Decl -> (Position, Size) -> [StyLine] -> Picture)- -- also (Label -> (Position, Size) -> [StyLine] -> Picture)---- if we do a demo entirely w/o optimization... is that easier? and how would I do it?- -- layout algo (for initial state, at least): randomly place objs (sets, points) w/ no constraints- -- or place aligned horizontally so they don't intersect, choose radius as fn of # unconstrained objs?- -- for constraints: for any set that's a subset of another, pick a smaller radius & place it inside that set.- -- constraints: same for points (in fact, easier for points)--place it (at r/2, 45 degrees) inside that set- -- there's no validation... a point/set could be in multiple sets?? assume not- -- at this point we're almost hardcoding the diagram? not necessarily- -- TODO actually hardcode the diagram in gloss; seeing the final representation will help- -- add'l constraint: all other objects should not intersect. use optimization to maintain exclusion?--- it seems likely that i'll get rid of the opt part for diagrams--might rewrite code instead of using opt code---- BUT can I use opt for labels, given a fixed diagram state?- -- put all labels in center. set label is attracted to center or just-outside-or-inside border of set,- -- point label is attracted to just-outside-point, map label attracted to center- -- all labels repulsed from other objects and labels.- -- would hardcoding label locations be a bad thing to do?- -- creating unconstrained objective fn: f :: DiagramInfo -> LabelInfo -> Label Positions -> Label Positions- -- where f info pos = f_attract info pos + f_repel info pos, and each includes the pairwise interactions- -- can autodiff deal with this? does this preserve the (forall a. Floating a => [a] -> a) type?- -- is the function too complicated for autodiff?---- TODO simple optimizer type, using state (Position and Size): ??- -- optimization fn: put all sets at the center, then use centerAndRepel. how to maintain subset?--- the things the optimizer needs to know are Name, Position, Size, SubObjType (which includes names of other objects that this one is linked to, e.g. Map)... (later: needs to know Direction Label Scale AbsPos)--- and it updates the Position and possibly the Size---- TODO how to synthesize the objective functions and constraint functions and implicit constraints?--- pairwise interactions? see above---- Since the compiler and the runtime share the layout representation,--- I'm going to re-type it here since the rep may change.--- Runtime imports Compiler as qualified anyway, so I can just convert the types again there.--- Here: removing selc / sell (selected). Don't forget they should satisfy Located typeclass-data Circ = Circ { namec :: String- , xc :: Float- , yc :: Float- , r :: Float }- deriving (Eq, Show)--data Label' = Label' { xl :: Float- , yl :: Float- , textl :: String- , scalel :: Float } -- calculate h,w from it- deriving (Eq, Show)--data Obj = C Circ | L Label' deriving (Eq, Show)--defaultRad = 100---- TODO these functions are now unused--- declToShape :: SubDecl -> [Obj]--- declToShape (Decl (OS (Set' name setType))) =--- case setType of--- Open -> [C $ Circ { namec = name, xc = 0, yc = 0, r = defaultRad }, L $ Label' { xl = 0, yl = 0, textl = name, scalel = 1 }]--- Closed -> [C $ Circ { namec = name, xc = 0, yc = 0, r = defaultRad }, L $ Label' { xl = 0, yl = 0, textl = name, scalel = 1 }]--- Unspecified -> [C $ Circ { namec = name, xc = 0, yc = 0, r = defaultRad }, L $ Label' { xl = 0, yl = 0, textl = name, scalel = 1 }]--- declToShape (Decl (OP (Pt' name))) = error "Substance -> Layout doesn't support points yet"--- declToShape (Decl (OM (Map' mapName fromSet toSet))) = error "Substance -> Layout doesn't support maps yet"---- toStateWithDefaultStyle :: [SubDecl] -> [Obj]--- toStateWithDefaultStyle decls = concatMap declToShape decls -- should use style---- subToLayoutRep :: SubSpec -> [Obj] -- this needs to know about the Obj type??--- subToLayoutRep spec = let (decls, constrs) = subSeparate spec in--- toStateWithDefaultStyle decls---- Substance + Style typechecker---- Substance + Style reference checker---- Produce the constraints and objective function---- Add rendering and interaction info to produce a world state for gloss--------------------------------------------- Runtime: layout algorithm picks a smart initial state--- then tries to satisfy constraints and minimize objective function, live and interactively--- TODO make module for this and optimization code--------------------------------------------- ghc compiler.hs; ./compiler <filename>.sub-parseSub = do- args <- getArgs- let fileIn = head args- program <- readFile fileIn- putStrLn $ show $ subParse program- putStrLn $ show $ subValidate program---- ghc compiler.hs; ./compiler <filename>.sty-parseSty = do- args <- getArgs- let fileIn = head args- program <- readFile fileIn- putStrLn $ styPrettyPrint $ styParse program---- ghc compiler.hs; ./compiler <filename>.sub <filename>.sty-subAndSty = do- args <- getArgs- let (subFile, styFile) = (head args, args !! 1) -- TODO usage- subIn <- readFile subFile- styIn <- readFile styFile- putStrLn $ subPrettyPrint $ subParse subIn- putStrLn "--------"- putStrLn $ styPrettyPrint $ styParse styIn--main = subAndSty
+ src/Element.hs view
@@ -0,0 +1,417 @@+-- | "Element" contains the grammers and parser for the+-- Element language++{-# OPTIONS_HADDOCK prune #-}+module Element where+--module Main (main) where -- for debugging purposes++import Utils+import System.Process+import Control.Monad (void)+import Data.Void+import System.IO -- read/write to file+import System.Environment+import Control.Arrow ((>>>))+import Control.Monad.State.Lazy (evalStateT)+import System.Random+import Debug.Trace+import Data.Functor.Classes+import Data.List+import Data.Tuple+import Data.Maybe (fromMaybe)+import Data.Typeable+import Text.Megaparsec+import Text.Megaparsec.Char+import Control.Monad.Combinators.Expr+import Text.Show.Pretty+import Env+-- import qualified Text.PrettyPrint as P+-- import Text.PrettyPrint.HughesPJClass hiding (colon, comma, parens, braces)+import qualified Data.Map.Strict as M+import qualified Text.Megaparsec.Char.Lexer as L+import qualified Tokenizer as T++--------------------------------------- Element AST -------------------------------++type ElementProg = [ElementStmt]++data ElementStmt = CdStmt Cd+ | VdStmt Vd+ | SubtypeDeclStmt SubtypeDecl+ | OdStmt Od+ | PdStmt Pd+ | SnStmt Sn -- Statement notation+ | PreludeDeclStmt Var T+ deriving (Show, Eq, Typeable)++-- | tconstructor+data Cd = Cd { nameCd :: String,+ inputCd :: [(Y, K)]}+ deriving (Eq, Typeable)++instance Show Cd where+ show (Cd nameCd inputCd) = "(TCon, " ++ nString ++ ", ValOfType "+ ++ iString ++ ")"+ where nString = show nameCd+ iString = show inputCd++-- | vconstructor+data Vd = Vd { nameVd :: String,+ varsVd :: [(Y, K)],+ typesVd :: [(Var, T)],+ toVd :: T }+ deriving (Eq, Typeable)++instance Show Vd where+ show (Vd nameVd varsVd typesVd toVd) =+ "(VCon, " ++ aString ++ ", forvars " ++ bString ++ ", fortypes " ++ cString+ ++ ", outputT " ++ dString ++ ")"+ where aString = show nameVd+ bString = show varsVd+ cString = show typesVd+ dString = show toVd++-- | Subtype declarations+data SubtypeDecl = SubtypeDecl { subType :: T,+ superType :: T }+ deriving (Eq, Typeable)++instance Show SubtypeDecl where+ show (SubtypeDecl subType superType) = aString ++ "Subtype of" ++ bString+ where aString = show subType+ bString = show superType++-- | predicates+data Od = Od { nameOd :: String,+ varsOd :: [(Y, K)],+ typesOd :: [(Var, T)],+ toOd :: T}+ deriving (Eq, Typeable)++instance Show Od where+ show (Od nameOd varsOd typesOd toOd) =+ "(Op, " ++ aString ++ ", forvars " ++ bString ++ ", fortypes " ++ cString+ ++ ", outputT " ++ dString ++ ")"+ where aString = show nameOd+ bString = show varsOd+ cString = show typesOd+ dString = show toOd++-- | predicates+data Pd = Pd1Const Pd1+ | Pd2Const Pd2+ deriving (Show, Eq, Typeable)++data Pd1 = Pd1 { namePd1 :: String,+ varsPd1 :: [(Y, K)],+ typesPd1 :: [(Var, T)]}+ deriving (Eq, Typeable)++instance Show Pd1 where+ show (Pd1 namePd1 varsPd1 typesPd1) =+ "(Pred, " ++ aString ++ ", forvars " ++ bString ++ ", fortypes " ++ cString+ ++ ", outputT " ++ ")"+ where aString = show namePd1+ bString = show varsPd1+ cString = show typesPd1++data Pd2 = Pd2 { namePd2 :: String,+ propsPd2 :: [(Var, Prop)]}+ deriving (Eq, Typeable)++instance Show Pd2 where+ show (Pd2 namePd2 propsPd2) =+ "(Pred, " ++ aString ++ ", forProps " ++ bString ++ ", outputT " ++ ")"+ where aString = show namePd2+ bString = show propsPd2++-- | Statement notation (for syntactic sugar)+data Sn = Sn {fromSn :: String, toSn :: String}+ deriving(Eq, Typeable)+instance Show Sn where+ show (Sn fromSn toSn) = "(notation: from: " ++ a ++ " to: " ++ b+ where a = show fromSn+ b = show toSn++----------------------------------------- Element Parser --------------------------++-- | 'ElementParser' is the top-level parser function. The parser contains a list+-- of functions that parse small parts of the language. When parsing a source+-- program, these functions are invoked in a top-down manner.++-- Parse all the statemnts between the spaces to the end of the input file+elementParser :: BaseParser [ElementStmt]+elementParser = evalStateT elementParser' Nothing++elementParser' :: Parser [ElementStmt]+elementParser' = between scn eof elementProgParser++-- |'elementProg' parses the entire actual Element program which is a collection of+-- constructors followed by a collection of operations followed by a collection+-- of predicates+elementProgParser :: Parser [ElementStmt]+elementProgParser = elementStmt `sepEndBy` newline'++elementStmt :: Parser ElementStmt+elementStmt = try snParser <|> try cdParser <|> try vdParser+ <|> try odParser <|> try subtypeDeclParser <|> try pdParser+ <|> try preludeParser++-- | type constructor parser+cdParser, cd1, cd2 :: Parser ElementStmt+cdParser = try cd1 <|> cd2+cd1 = do+ rword "type"+ name <- identifier+ (y, k) <- parens ykParser+ pos <- getSourcePos+ return (CdStmt Cd { nameCd = name, inputCd = zip y k})+cd2 = do+ rword "type"+ name <- identifier+ return (CdStmt Cd { nameCd = name, inputCd = []})++-- | sub type declarations parser+subtypeDeclParser :: Parser ElementStmt+subtypeDeclParser = do+ subtype <- tParser+ rword "<:"+ supertype <- tParser+ return $ SubtypeDeclStmt $+ SubtypeDecl {subType = subtype, superType = supertype}++-- | prelude declarations parser+preludeParser :: Parser ElementStmt+preludeParser = do+ rword "value"+ pvar <- varParser+ rword ":"+ ptype <- tParser+ return $ PreludeDeclStmt pvar ptype++-- | parser for the (y,k) list+ykParser :: Parser ([Y], [K])+ykParser = unzip <$> (yWithKind `sepBy1` comma)+ where yWithKind = (,) <$> (yParser <* colon) <*> kParser+++varWithTypeParser :: Parser (Var,T)+varWithTypeParser = do+ t <- tParser+ v <- option (VarConst "") varParser+ return (v,t)++varWithTypeParserNonOptional :: Parser (Var,T)+varWithTypeParserNonOptional = do+ t <- tParser+ v <- varParser+ return (v,t)++-- | parser for the (b,t) list with optional var names+xtParser :: Parser ([Var], [T])+xtParser = unzip <$> (varWithTypeParser `sepBy1` star)++-- | parser for the (b,t) list with mandatory var names+xtParserNonOptional :: Parser ([Var], [T])+xtParserNonOptional = unzip <$> (varWithTypeParserNonOptional `sepBy1` star)++vpPairParser :: Parser (Var,Prop)+vpPairParser = do+ p <- propParser+ v <- varParser+ return (v,p)++-- | parser for the (x, Prop) list+xPropParser :: Parser ([Var], [Prop])+xPropParser = unzip <$> (vpPairParser `sepBy1` star)++-- | var constructor parser+vdParser :: Parser ElementStmt+vdParser = do+ rword "constructor"+ name <- identifier+ colon+ (y', k') <- option ([], []) $ brackets ykParser+ (b', t') <- option ([], []) $ xtParserNonOptional+ arrow+ t'' <- tParser+ v <- option (VarConst "") varParser+ return (VdStmt Vd { nameVd = name, varsVd = zip y' k',+ typesVd = zip b' t', toVd = t'' })++-- | operation parser+odParser :: Parser ElementStmt+odParser = do+ rword "function"+ name <- identifier+ colon+ (y', k') <- option ([], []) $ brackets ykParser+ (b', t') <- option ([], []) xtParser+ arrow+ t'' <- tParser+ v <- option (VarConst "") varParser+ return (OdStmt Od { nameOd = name, varsOd = zip y' k', typesOd = zip b' t',+ toOd = t'' })++-- | predicate parser+pdParser, pd1, pd2 :: Parser ElementStmt+pdParser = try pd2 <|> pd1+pd1 = do+ rword "predicate"+ name <- identifier+ colon+ (y', k') <- option ([], []) $ brackets ykParser+ (b', t') <- option ([], []) xtParser+ return (PdStmt (Pd1Const (Pd1 { namePd1 = name, varsPd1 = zip y' k',+ typesPd1 = zip b' t'})))+pd2 = do+ rword "predicate"+ name <- identifier+ colon+ (b', prop') <- xPropParser+ return (PdStmt (Pd2Const (Pd2 { namePd2 = name, propsPd2 = zip b' prop'})))++snParser :: Parser ElementStmt+snParser = do+ rword "notation"+ quote+ toSn' <- manyTill anySingle quote+ tilde+ quote+ fromSn' <- manyTill anySingle quote+ return (SnStmt (Sn {fromSn = fromSn', toSn = toSn'}))+++-------------------------- Element Semantic Checker -------------------------------++-- | 'check' is the top-level semantic checking function. It takes a Element+-- program as the input, checks the validity of the program acoording to the+-- typechecking rules, and outputs a collection of information.++check :: ElementProg -> VarEnv+check p =+ let env = foldl checkElementStmt initE p+ in if null (errors env)+ then env+ else error $ "Element type checking failed with the following problems: \n"+ ++ (ppShow $ errors env) ++ ppShow env+ where initE = VarEnv { typeConstructors = M.empty, valConstructors = M.empty,+ operators = M.empty, predicates = M.empty, typeVarMap = M.empty,+ typeValConstructor = M.empty, varMap = M.empty, subTypes = [],+ stmtNotations = [], typeCtorNames = [], preludes = [],+ declaredNames = [], errors = ""}++checkElementStmt :: VarEnv -> ElementStmt -> VarEnv+checkElementStmt e (CdStmt c) =+ let kinds = seconds (inputCd c)+ env1 = foldl checkK e kinds+ tc = TypeConstructor { nametc = nameCd c, kindstc = kinds}+ ef = addName (nameCd c) env1+ in ef { typeConstructors = M.insert (nameCd c) tc $ typeConstructors ef }++checkElementStmt e (SubtypeDeclStmt s) =+ let env1 = checkDeclaredType e (subType s)+ env2 = checkDeclaredType env1 (superType s)+ env3 = env2 { subTypes = (subType s,superType s) : subTypes env2 }+ in env3++checkElementStmt e (PreludeDeclStmt (VarConst pvar) ptype) =+ let env = checkT e ptype+ in env { preludes = ((VarConst pvar), ptype) : preludes env }++checkElementStmt e (VdStmt v) =+ let kinds = seconds (varsVd v)+ env1 = foldl checkK e kinds+ localEnv = foldl updateEnv env1 (varsVd v)+ args = seconds (typesVd v)+ res = toVd v+ env2 = foldl checkT localEnv args+ env3 = checkT env2 res+ vc = ValConstructor { namevc = nameVd v, ylsvc = firsts (varsVd v),+ kindsvc = seconds (varsVd v),+ nsvc = firsts (typesVd v), tlsvc = seconds (typesVd v),+ tvc = toVd v }+ e1 = addName (nameVd v) env3+ ef = addValConstructor vc e1+ in if env2 == e || env2 /= e && env3 == e || env3 /= e && e1 == e || e1 /= e+ then ef { valConstructors = M.insert (nameVd v) vc $ valConstructors ef }+ else error "Error!" -- Does not suppose to reach here++checkElementStmt e (OdStmt v) =+ let kinds = seconds (varsOd v)+ env1 = foldl checkK e kinds+ localEnv = foldl updateEnv env1 (varsOd v)+ args = seconds (typesOd v)+ res = toOd v+ env2 = foldl checkT localEnv args+ env3 = checkT env2 res+ op = Operator { nameop = nameOd v, ylsop = firsts (varsOd v),+ kindsop = seconds (varsOd v), tlsop = seconds (typesOd v),+ top = toOd v }+ ef = addName (nameOd v) env3+ in if env2 == e || env2 /= e && env3 == e || env3 /= e+ then ef { operators = M.insert (nameOd v) op $ operators ef }+ else error "Error!" -- Does not suppose to reach here++checkElementStmt e (PdStmt (Pd1Const v)) =+ let kinds = seconds (varsPd1 v)+ env1 = foldl checkK e kinds+ localEnv = foldl updateEnv env1 (varsPd1 v)+ args = seconds (typesPd1 v)+ env2 = foldl checkT localEnv args+ pd1 = Pred1 $ Prd1 { namepred1 = namePd1 v,ylspred1 = firsts (varsPd1 v),+ kindspred1 = seconds (varsPd1 v), tlspred1 = seconds (typesPd1 v)}+ ef = addName (namePd1 v) e+ in if env2 == e || env2 /= e+ then ef { predicates = M.insert (namePd1 v) pd1 $ predicates ef }+ else error "Error!" -- Does not suppose to reach here++checkElementStmt e (PdStmt (Pd2Const v)) =+ let pd = Pred2 $ Prd2 { namepred2 = namePd2 v,+ plspred2 = seconds (propsPd2 v)}+ ef = addName (namePd2 v) e+ in ef { predicates = M.insert (namePd2 v) pd $ predicates ef }++checkElementStmt e (SnStmt s) =+ let (from,to,patterns,entities) = T.translatePatterns (fromSn s, toSn s) e+ newSnr = StmtNotationRule {fromSnr = from,+ toSnr = to, patternsSnr = patterns, entitiesSnr = entities}+ in e {stmtNotations = newSnr : stmtNotations e}++computeSubTypes :: VarEnv -> VarEnv+computeSubTypes e = let env1 = e { subTypes = transitiveClosure (subTypes e)}+ in if isClosureNotCyclic (subTypes env1) then+ env1+ else env1 { errors = errors env1 +++ "Cyclic Subtyping Relation! \n"}+++-- | 'parseElement' runs the actual parser function: 'elementParser', taking in a+-- program String, parses it and semantically checks it. It outputs the+-- environement as returned from the element typechecker+parseElement :: String -> String -> Either CompilerError VarEnv+parseElement elementFile elementIn =+ case runParser elementParser elementFile elementIn of+ Left err -> Left $ ElementParse $ (errorBundlePretty err)+ Right prog ->+ let env = check prog+ env1 = computeSubTypes env+ in Right env1+++----------------------------- Test Driver --------------------------------------+-- | For testing: first uncomment the module definition to make this module the+-- Main module. Usage: ghc Element.hs; ./Element <element-file> <output-file>++main :: IO ()+main = do+ [elementFile, outputFile] <- getArgs+ elementIn <- readFile elementFile+ case parse elementParser elementFile elementIn of+ Left err -> putStr (errorBundlePretty err)+ Right xs -> do+ writeFile outputFile (show xs)+ let o = check xs+ print o+ putStrLn "Parsing Done!"+ return ()
+ src/Env.hs view
@@ -0,0 +1,555 @@+-- | "Env" Contains all the shared code among substance and dsll:+-- AST, parser and typechecking functions+-- It also contains the environemt for the typechecker++{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+++module Env where+--module Main (main) where -- for debugging purposes++import Utils+import System.Process+import Control.Monad (void)+import Data.Void+import GHC.Generics+import System.IO -- read/write to file+import System.Environment+import Control.Arrow ((>>>))+import System.Random+import Debug.Trace+import Data.Functor.Classes+import Data.List+import Data.Maybe (fromMaybe)+import Control.Monad (void)+import Data.Typeable+import Text.Megaparsec+import Text.Megaparsec.Char+import Control.Monad.Combinators.Expr+import Data.Void+import Control.Monad.State.Lazy (StateT)+--import Text.PrettyPrint+--import Text.PrettyPrint.HughesPJClass hiding (colon, comma, parens, braces)+-- import qualified Data.Text +import qualified Data.Set as S+import qualified Data.Map.Strict as M+import qualified Text.Megaparsec.Char.Lexer as L+import qualified SubstanceTokenizer as T+import qualified Data.Text as Text++--------------------------------------------------------------------------------+---- Lexer helper functions+-- TODO: separate reserved words and keywords for each of the DSLs++type BaseParser = Parsec ParserError String+type Parser = StateT (Maybe VarEnv) BaseParser+data ParserError+ = SubstanceError String+ | StyleError String+ deriving (Eq, Typeable, Ord, Read, Show)+instance ShowErrorComponent ParserError where+ showErrorComponent (SubstanceError msg) = "Substance Parser Error: " ++ msg++-- | custom source position type +data SourcePosition = SourcePosition + { column :: Int -- ^ column number of the symbol+ , row :: Int -- ^ row number of the symbol+ } deriving (Show, Eq)++rws, attribs, attribVs, shapes :: [String] -- list of reserved words+rws = ["avoid", "as"] ++ dsll+-- ++ types ++ attribs ++ shapes ++ colors+attribs = ["shape", "color", "label", "scale", "position"]+attribVs = shapes+shapes = ["Auto", "None", "Circle", "Box", "SolidArrow", "SolidDot",+ "HollowDot", "Cross"]+labelrws = ["Label", "AutoLabel", "NoLabel"]+dsll = ["tconstructor","vconstructor","operator","ExprNotation","StmtNotation",+ "forvars","fortypes","predicate", "Prop", "type", "<:", "->", "<->",+ "at level", "associativity"]+-- colors = ["Random", "Black", "Red", "Blue", "Yellow"]++upperId, lowerId, identifier :: Parser String+identifier = (lexeme . try) (p >>= checkId)+ where p = (:) <$> letterChar <*> many validChar+upperId = (lexeme . try) (p >>= checkId)+ where p = (:) <$> upperChar <*> many validChar+lowerId = (lexeme . try) (p >>= checkId)+ where p = (:) <$> lowerChar <*> many validChar+validChar = alphaNumChar <|> char '_' <|> char '-'++++transPattern :: Parser String+transPattern = (lexeme . try) (p >>= checkPattern)+ where p = many anySingle --(:) <$> letterChar <*> many validChar++checkPattern :: String -> Parser String+checkPattern x = if x == "\"" || x == "->"+ then fail $ "keyword " ++ show x ++ " cannot be an identifier"+ else return x++checkId :: String -> Parser String+checkId x = if x `elem` rws+ then fail $ "keyword " ++ show x ++ " cannot be an identifier"+ else return x++texExpr :: Parser String+texExpr = dollar >> manyTill asciiChar dollar++-- | 'lineComment' and 'blockComment' are the two styles of commenting in Penrose. Line comments start with @--@. Block comments are wrapped by @/*@ and @*/@.+lineComment, blockComment :: Parser ()+lineComment = L.skipLineComment "--"+blockComment = L.skipBlockComment "/*" "*/"++-- | A strict space consumer. 'sc' only eats space and tab characters. It does __not__ eat newlines.+sc :: Parser ()+sc = L.space (void $ takeWhile1P Nothing f) lineComment empty+ where+ f x = x == ' ' || x == '\t'++-- | A normal space consumer. 'scn' consumes all whitespaces __including__ newlines.+scn :: Parser ()+scn = L.space space1 lineComment blockComment++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++symbol :: String -> Parser String+symbol = L.symbol sc++symboln :: String -> Parser String+symboln = L.symbol scn++newline' :: Parser ()+newline' = newline >> scn++semi' :: Parser ()+semi' = semi >> scn++backticks :: Parser a -> Parser a+backticks = between (symbol "`") (symbol "`")++semi, def, lparen, rparen, lbrac, rbrac, colon, arrow, comma, dollar, question, dot :: Parser ()+aps = void (symbol "'")+quote = void (symbol "\"")+lbrac = void (symbol "{")+rbrac = void (symbol "}")+lparen = void (symbol "(")+rparen = void (symbol ")")+slparen = void (symbol "[")+srparen = void (symbol "]")+colon = void (symbol ":")+semi = void (symbol ";")+arrow = void (symbol "->")+comma = void (symbol ",")+dot = void (symbol ".")+eq = void (symbol "=")+def = void (symbol ":=")+dollar = void (symbol "$")+question = void (symbol "?")+tilde = void (symbol "~")+star = void (symbol "*")+++dollars :: Parser a -> Parser a+dollars = between (symbol "$") (symbol "$")++braces :: Parser a -> Parser a+-- NOTE: symboln is used here because all usages of braces in our system allow newlines in the middle of a stmt+-- May wanna change this later once we have stricter use case of it+braces = between (symboln "{") (symbol "}")++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++brackets :: Parser a -> Parser a+brackets = between (symbol "[") (symbol "]")++-- | 'integer' parses an integer.+integer :: Parser Integer+unsignedInteger = lexeme L.decimal+integer = L.signed sc unsignedInteger++-- | 'float' parses a floating point number.+float :: Parser Float+unsignedFloat = lexeme L.float+float = L.signed sc unsignedFloat++-- Reserved words+rword :: String -> Parser ()+rword w = lexeme (string w *> notFollowedBy alphaNumChar)++tryChoice :: [Parser a] -> Parser a+tryChoice list = choice $ map try list++----------------------------------- AST ----------------------------------------++data TypeName = TypeNameConst String -- these are all names, e.g. “Set”+ | AllT -- specifically for global selection in Style+ deriving (Show, Eq, Typeable)++data TypeVar = TypeVar { typeVarName :: String,+ typeVarPos :: SourcePos }+ deriving (Show, Typeable)++instance Eq TypeVar where+ (TypeVar n1 _) == (TypeVar n2 _) = n1 == n2++instance Ord TypeVar where+ (TypeVar s1 _) `compare` (TypeVar s2 _) = s1 `compare` s2++newtype Var = VarConst String+ deriving (Show, Eq, Typeable, Ord)+var2string (VarConst v) = v++data Y = TypeVarY TypeVar+ | VarY Var+ deriving (Show, Eq, Typeable, Ord)++data T = TTypeVar TypeVar+ | TConstr TypeCtorApp+ -- TODO: rename to TCtor. Less confusing, more consistent w/ Sty+ deriving (Show, Eq, Typeable, Ord)++data TypeCtorApp = TypeCtorApp { nameCons :: String,+ argCons :: [Arg],+ constructorInvokerPos :: SourcePos }+ deriving (Typeable)++instance Show TypeCtorApp where+ show (TypeCtorApp nameCons argCons posCons) = nString ++ "(" ++ aString ++ ")"+ where nString = show nameCons+ aString = show argCons++instance Eq TypeCtorApp where+ (TypeCtorApp n1 a1 _) == (TypeCtorApp n2 a2 _) = n1 == n2 && a1 == a2++instance Ord TypeCtorApp where+ (TypeCtorApp s1 _ _) `compare` (TypeCtorApp s2 _ _) = s1 `compare` s2++data Arg = AVar Var+ | AT T+ deriving (Show, Eq, Typeable, Ord)++data K = Ktype Type+ | KT T+ deriving (Show, Eq, Typeable)++data Type = Type { typeName :: String,+ typePos :: SourcePos }+ deriving (Show, Typeable)++instance Eq Type where+ (Type n1 _) == (Type n2 _) = n1 == n2++data Prop = Prop { propName :: String,+ propPos :: SourcePos }+ deriving (Show, Typeable)++instance Eq Prop where+ (Prop n1 _) == (Prop n2 _) = n1 == n2++----------------------------------- Parser -------------------------------------++typeNameParser :: Parser TypeName+typeNameParser = TypeNameConst <$> identifier++typeParser :: Parser Type+typeParser = do+ rword "type"+ pos <- getSourcePos+ return Type{ typeName = "type", typePos = pos}++varParser :: Parser Var+varParser = VarConst <$> identifier++typeVarParser :: Parser TypeVar+typeVarParser = do+ aps+ i <- identifier+ pos <- getSourcePos+ return TypeVar { typeVarName = i, typeVarPos = pos}++yParser, y1, y2 :: Parser Y+yParser = try y1 <|> y2+y1 = VarY <$> varParser+y2 = TypeVarY <$> typeVarParser++propParser :: Parser Prop+propParser = do+ rword "Prop"+ pos <- getSourcePos+ return Prop { propName = "Prop", propPos = pos}++tParser, tTypeCtorAppParser, typeVarParser' :: Parser T+tParser = try tTypeCtorAppParser <|> typeVarParser'+tTypeCtorAppParser = do+ i <- identifier+ arguments <- option [] $ parens (argParser `sepBy1` comma)+ --try (parens (argParser `sepBy1` comma)) <|> emptyArgList --option [] $+ -- parens (argParser `sepBy1` comma)+ --try (parens (argParser `sepBy1` comma)) <|> emptyArgList+ pos <- getSourcePos+ return (TConstr (TypeCtorApp { nameCons = i, argCons = arguments,+ constructorInvokerPos = pos }))+typeVarParser' = TTypeVar <$> typeVarParser++argParser, varParser', tParser' :: Parser Arg+argParser = try tParser' <|> varParser'+varParser' = AVar <$> varParser+tParser' = AT <$> tParser++kParser, kTypeParser, tParser'' :: Parser K+kParser = try kTypeParser <|> try tParser''+kTypeParser = do+ rword "type"+ pos <- getSourcePos+ return (Ktype (Type { typeName = "type", typePos = pos }))+tParser'' = KT <$> tParser++emptyArgList :: Parser [Arg]+emptyArgList = do+ lparen+ rparen+ return []++----------------------------------- Utility functions ------------------------------------------++-- Equality functions that don't compare SourcePos+-- TODO: use correct equality comparison in typechecker++argsEq :: Arg -> Arg -> Bool+argsEq (AVar v1) (AVar v2) = v1 == v2+argsEq (AT t1) (AT t2) = typesEq t1 t2+argsEq _ _ = False++typesEq :: T -> T -> Bool+typesEq (TTypeVar t1) (TTypeVar t2) = typeVarName t1 == typeVarName t2 -- TODO: better way to compare type vars+typesEq (TConstr t1) (TConstr t2) = nameCons t1 == nameCons t2 &&+ length (argCons t1) == length (argCons t2) &&+ (all (\(a1, a2) -> argsEq a1 a2) $ zip (argCons t1) (argCons t2))+typesEq _ _ = False++----------------------------------- Typechecker aux functions ------------------------------------------++-- | Compute the transitive closure of list of pairs+-- Useful for subtyping and equality subtyping checkings+transitiveClosure :: Eq a => [(a, a)] -> [(a, a)]+transitiveClosure closure+ | closure == closureAccum = closure+ | otherwise = transitiveClosure closureAccum+ where closureAccum =+ nub $ closure ++ [(a, c) | (a, b) <- closure, (b', c) <- closure, b == b']++-- | Return whether a closure is cyclic (a, b) and (b, a) appears in the closure+isClosureNotCyclic :: Eq a => [(a,a)] -> Bool+isClosureNotCyclic lst = let c = [(a,a') | (a,a') <- lst, a == a']+ in null c++firsts :: [(a, b)] -> [a]+firsts xs = [x | (x,_) <- xs]++seconds :: [(a, b)] -> [b]+seconds xs = [x | (_,x) <- xs]++second :: (a, b) -> b+second (a, b) = b++checkAndGet :: String -> M.Map String v -> SourcePos -> Either String v+checkAndGet k m pos = case M.lookup k m of+ Nothing -> Left ("Error in " ++ sourcePosPretty pos ++ " : " ++ k+ ++ " Doesn't exist in the context \n")+ Just v -> Right v++lookUpK :: VarEnv -> Arg -> K+lookUpK e (AT (TTypeVar t)) = Ktype (typeVarMap e M.! t)+--(Ktype (Type {typeName = "type", typePos = typeVarPos t }))+lookUpK e (AT (TConstr t)) =+ if nameCons t `elem` declaredNames e+ then lookUpK e (AVar (VarConst (nameCons t)))+ else Ktype (Type { typeName = "type", typePos = constructorInvokerPos t })+lookUpK e (AVar v) = KT (varMap e M.! v)++getTypesOfArgs :: VarEnv -> [Arg] -> [K]+getTypesOfArgs e = map (lookUpK e)++updateEnv :: VarEnv -> (Y, K) -> VarEnv+updateEnv e (TypeVarY y, Ktype t) = e { typeVarMap = M.insert y t $ typeVarMap e }+updateEnv e (VarY y, KT t) = e { varMap = M.insert y t $ varMap e }+updateEnv e err = e { errors = errors e+ ++ "Problem in update: " ++ show err ++ "\n" }++addName :: String -> VarEnv -> VarEnv+addName a e = if a `elem` typeCtorNames e+ then e { errors = errors e ++ "Name " ++ a +++ " already exists in the context \n" }+ else e { typeCtorNames = a : typeCtorNames e }++addValConstructor :: ValConstructor -> VarEnv -> VarEnv+addValConstructor v e = e { typeValConstructor = M.insert (tvc v) v $ typeValConstructor e }+-- Allow multiple value constructors for a type (e.g. List(`X) has Cons[`X] and Nil[`X]++addDeclaredName :: String -> VarEnv -> VarEnv+addDeclaredName a e = if a `elem` declaredNames e+ then e { errors = errors e ++ "Name " ++ a+ ++ " already exsist in the context \n"}+ else e { declaredNames = a : declaredNames e }++isSubtype :: T -> T -> VarEnv -> Bool+isSubtype t1 t2 e = typesEq t1 t2 -- A type is considered a subtype of itself+ || (t1,t2) `elem` subTypes e++isSubtypeK :: K -> K -> VarEnv -> Bool+isSubtypeK (KT k1) (KT k2) e = isSubtype k1 k2 e++-- | For existing judgment G |- T1 <: T2,+-- | this rule (SUBTYPE-ARROW) checks if the first arrow type (i.e. function or value constructor type) is a subtype of the second+-- | The arrow types are contravariant in their arguments and covariant in their return type+-- | e.g. if Cat <: Animal, then Cat -> Cat <: Cat -> Animal, and Animal -> Cat <: Cat -> Cat+isSubtypeArrow :: [T] -> [T] -> VarEnv -> Bool+isSubtypeArrow [t] [s] e = isSubtype t s e+ -- Covariant in return type (or simply the type for a nullary function)+isSubtypeArrow (t1:ts) (s1:ss) e = isSubtype s1 t1 e -- Contravariant in arguments+ && isSubtypeArrow ts ss e+isSubtypeArrow t s _ = False -- Functions have different numbers of arguments++--------------------------------------- Env Data Types ---------------------------------------++-- | Environment for the dsll semantic checker. As the 'check' function+-- executes, it accumulate information such as symbol tables in the environment.++-- | list of elements that might appear in the global context+data Ttype = Ttype { yt :: Y,+ kt :: K }+ deriving (Show, Eq, Typeable)++data TypeConstructor = TypeConstructor { nametc :: String,+ kindstc :: [K]}+ deriving (Show, Eq, Typeable)++data ValConstructor = ValConstructor { namevc :: String,+ ylsvc :: [Y],+ kindsvc :: [K],+ nsvc :: [Var],+ tlsvc :: [T],+ tvc :: T }+ deriving (Show, Eq, Typeable)++data Operator = Operator { nameop :: String,+ ylsop :: [Y],+ kindsop :: [K],+ tlsop :: [T],+ top :: T}+ deriving (Show, Eq, Typeable)++data PredicateEnv = Pred1 Predicate1+ | Pred2 Predicate2+ deriving (Show, Eq, Typeable)++data Predicate1 = Prd1 { namepred1 :: String,+ ylspred1 :: [Y],+ kindspred1 :: [K],+ tlspred1 :: [T]}+ deriving (Show, Eq, Typeable)++data Predicate2 = Prd2 { namepred2 :: String,+ plspred2 :: [Prop]}+ deriving (Show, Eq, Typeable)++data StmtNotationRule =+ StmtNotationRule { fromSnr :: [T.Token],+ toSnr :: [T.Token],+ patternsSnr :: [T.Token],+ entitiesSnr :: [T.Token] -- all the non pattern sugared entities+ }+ deriving (Show, Eq, Typeable)++data ExprNotationRule = ExprNotationRule {fromEnr :: String,+ toEnr :: String,+ associativityEnr :: String,+ precedenceEnr :: Integer}+ deriving (Show, Eq, Typeable)++data VarEnv = VarEnv+ { typeConstructors :: M.Map String TypeConstructor+ , valConstructors :: M.Map String ValConstructor+ , operators :: M.Map String Env.Operator+ , predicates :: M.Map String PredicateEnv+ , typeVarMap :: M.Map TypeVar Type+ , typeValConstructor :: M.Map T ValConstructor+ , varMap :: M.Map Var T+ , preludes :: [(Var, T)]+ , subTypes :: [(T, T)]+ , typeCtorNames :: [String] -- a global list which contains all the names of types in that env+ , declaredNames :: [String] -- a global list which contains all the names of elements declared in that env+ , stmtNotations :: [StmtNotationRule] -- all the statement notations in the dsll+ , errors :: String -- a string which accumulates all the errors founded during the run of the typechecker+ } deriving (Show, Eq, Typeable)++isDeclared :: String -> VarEnv -> Bool+isDeclared name varEnv = name `elem` typeCtorNames varEnv++checkTypeVar :: VarEnv -> TypeVar -> VarEnv+checkTypeVar e v = if M.member v (typeVarMap e)+ then e+ else e { errors = errors e ++ ("TypeVar " +++ show v ++ "is not in scope \n") }++checkVar :: VarEnv -> Var -> VarEnv+checkVar e v = if M.member v (varMap e)+ then e+ else e { errors = errors e ++ ("Var " ++ show v+ ++ "is not in scope \n") }+++checkY :: VarEnv -> Y -> VarEnv+checkY e (TypeVarY y) = checkTypeVar e y+checkY e (VarY y) = checkVar e y++checkArg :: VarEnv -> Arg -> VarEnv+checkArg e (AVar v) = checkVar e v+checkArg e (AT (TConstr i)) = if nameCons i `elem` declaredNames e+ then checkVar e (VarConst (nameCons i))+ else checkT e (TConstr i)+checkArg e (AT t) = checkT e t++checkT :: VarEnv -> T -> VarEnv+checkT e (TTypeVar t) = checkTypeVar e t+checkT e (TConstr c) = let env1 = checkTypeCtorApp e c+ env2 = checkDeclaredType env1 (TConstr c)+ in env2++checkType :: VarEnv -> Type -> VarEnv+checkType e t = e++checkTypeCtorApp :: VarEnv -> TypeCtorApp -> VarEnv+checkTypeCtorApp e const =+ let name = nameCons const+ args = argCons const+ env1 = foldl checkArg e args+ kinds1 = getTypesOfArgs e args+ in case checkAndGet name (typeConstructors e) (constructorInvokerPos const) of+ Right val -> let kinds2 = kindstc val+ in if kinds1 /= kinds2+ then env1 { errors = errors env1+ ++ ("Args do not match: " ++ show kinds1 +++ " != " ++ show kinds2 ++ "\n") }+ else env1+ Left err -> env1 { errors = errors env1 ++ err }++checkDeclaredType :: VarEnv -> T -> VarEnv+checkDeclaredType e (TConstr t) =+ if nameCons t `elem` typeCtorNames e+ then e+ else e { errors = errors e ++ "Type " ++ nameCons t +++ " does not exsist in the context \n" }++checkDeclaredType e _ = e { errors = errors e +++ "checkDeclaredType should be called only with type constructors \n" }+++checkK :: VarEnv -> K -> VarEnv+checkK e (Ktype t) = checkType e t+checkK e (KT t) = checkT e t
src/Functions.hs view
@@ -1,335 +1,1676 @@-{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction #-}-module Functions where-import Shapes-import Utils-import qualified Data.Map.Strict as M------------------------- Sample objective functions that operate on objects (given names)--- TODO write about expectations for the objective function writer---- type ObjFnOn a = forall a. (Floating a, Real a, Show a, Ord a) => [Name] -> M.Map Name (Obj' a) -> a-type ObjFnOn a = forall a. (Floating a, Real a, Show a, Ord a) => [Obj' a] -> a--- illegal polymorphic or qualified type--can't return a forall?-type ObjFnNamed a = forall a. (Floating a, Real a, Show a, Ord a) => M.Map Name (Obj' a) -> a-type Weight a = a---- TODO deal with lists in a more principled way--- maybe the typechecking should be done elsewhere...--- shouldn't these two be parametric over objects?-centerCirc :: ObjFnOn a-centerCirc [C' c] = (xc' c)^2 + (yc' c)^2-centerCirc [L' _] = error "misnamed label"---- distanceOf :: ObjFnOn a--- toLeft [fromname, toname] dict =--- case (M.lookup fromname dict, M.lookup toname dict) of--- -- (Just (A' a), Just (S' s), Just (S' e)) ->--- -- (Just (A' a), Just (S' s), Just (C' e)) ->--- -- (Just (A' a), Just (C' s), Just (S' e)) ->--- (Just (C' s), Just (C' e)) ->--- -- (fromx - sx)^2 + (fromy - sy)^2 + (tox - ex)^2 + (toy - ey)^2--- (xc' s - xc' e + 400)^2--onTop :: ObjFnOn a-onTop [L' s, L' e] = (yl' s - yl' e - 100)^2--sameHeight :: ObjFnOn a-sameHeight [C' s, S' e] = (yc' s - ys' e)^2-sameHeight [S' s, C' e] = (ys' s - yc' e)^2-sameHeight [C' s, C' e] = (yc' s - yc' e)^2-sameHeight [S' s, S' e] = (ys' s - ys' e)^2-sameHeight [L' s, L' e] = (yl' s - yl' e)^2--sameX :: ObjFnOn a-sameX [C' s, S' e] = (xc' s - xs' e)^2-sameX [S' s, C' e] = (xs' s - xc' e)^2-sameX [C' s, C' e] = (xc' s - xc' e)^2-sameX [S' s, S' e] = (xs' s - xs' e)^2-sameX [L' s, L' e] = (xl' s - xl' e)^2--sameCenter :: ObjFnOn a-sameCenter [C' s, S' e] = (yc' s - ys' e)^2 + (xc' s - xs' e)^2-sameCenter [S' s, C' e] = (ys' s - yc' e)^2 + (xs' s - xc' e)^2-sameCenter [C' s, C' e] = (yc' s - yc' e)^2 + (xc' s - xc' e)^2-sameCenter [S' s, S' e] = (ys' s - ys' e)^2 + (xs' s - xs' e)^2-sameCenter [L' s, L' e] = (yl' s - yl' e)^2 + (xl' s - xl' e)^2--toLeft :: ObjFnOn a-toLeft [C' s, S' e] = (xc' s - xs' e + 400)^2-toLeft [S' s, C' e] = (xs' s - xc' e + 400)^2--- toLeft [C' s, C' e] = (xc' s - xc' e + r' s + r' e + 200)^2-toLeft [C' s, C' e] = (xc' s - xc' e + 400)^2-toLeft [S' s, S' e] = (xs' s - xs' e + 400)^2-toLeft [L' s, L' e] = (xl' s - xl' e + 100)^2---centerMap :: ObjFnOn a-centerMap [A' a, S' s, S' e] = _centerMap a [xs' s, ys' s] [xs' e, ys' e]- [spacing + (halfDiagonal . side') s, negate $ spacing + (halfDiagonal . side') e]-centerMap [A' a, S' s, C' e] = _centerMap a [xs' s, ys' s] [xc' e, yc' e]- [spacing + (halfDiagonal . side') s, negate $ spacing + r' e]-centerMap [A' a, C' s, S' e] = _centerMap a [xc' s, yc' s] [xs' e, ys' e]- [spacing + r' s, negate $ spacing + (halfDiagonal . side') e]-centerMap [A' a, C' s, C' e] = _centerMap a [xc' s, yc' s] [xc' e, yc' e]- [ spacing * r' s, negate $ spacing * r' e]-centerMap [A' a, L' s, L' e] = _centerMap a [xl' s, yl' s] [xl' e, yl' e]- [spacing * hl' s, negate $ spacing * hl' e]-centerMap [A' a, L' s, C' e] = _centerMap a [xl' s, yl' s] [xc' e, yc' e]- [spacing, negate $ spacing + r' e]-centerMap o = error ("CenterMap: unsupported arguments: " ++ show o)-spacing = 1.1 -- TODO: arbitrary--_centerMap :: forall a. (Floating a, Real a, Show a, Ord a) =>- SolidArrow' a -> [a] -> [a] -> [a] -> a-_centerMap a s1@[x1, y1] s2@[x2, y2] [o1, o2] =- let vec = [x2 - x1, y2 - y1] -- direction the arrow should point to- dir = normalize vec -- direction the arrow should point to- [sx, sy, ex, ey] = if norm vec > o1 + abs o2- then (s1 +. o1 *. dir) ++ (s2 +. o2 *. dir) else s1 ++ s2- [fromx, fromy, tox, toy] = [startx' a, starty' a, endx' a, endy' a] in- (fromx - sx)^2 + (fromy - sy)^2 + (tox - ex)^2 + (toy - ey)^2--repel :: ObjFnOn a-repel [C' c, S' d] = 1 / distsq (xc' c, yc' c) (xs' d, ys' d) - r' c - side' d + epsd-repel [S' c, C' d] = 1 / distsq (xc' d, yc' d) (xs' c, ys' c) - r' d - side' c + epsd-repel [C' c, C' d] = 1 / distsq (xc' c, yc' c) (xc' d, yc' d) - r' c - r' d + epsd-repel [L' c, L' d] =- if c == d then 0 else 1 / distsq (xl' c, yl' c) (xl' d, yl' d)-repel [L' c, C' d] = if labelName (namec' d) == namel' c then 0 else 1 / distsq (xl' c, yl' c) (xc' d, yc' d)-repel [C' c, L' d] = 1 / distsq (xc' c, yc' c) (xl' d, yl' d)-repel [L' c, S' d] = if labelName (names' d) == namel' c then 0 else 1 / distsq (xl' c, yl' c) (xs' d, ys' d)-repel [S' c, L' d] = 1 / distsq (xs' c, ys' c) (xl' d, yl' d)-repel [A' c, L' d] = repel' (startx' c, starty' c) (xl' d, yl' d) +- repel' (endx' c, endy' c) (xl' d, yl' d)-repel [A' c, C' d] = repel' (startx' c, starty' c) (xc' d, yc' d) +- repel' (endx' c, endy' c) (xc' d, yc' d)-repel _ = error "invalid selectors in repel"--repel' x y = 1 / distsq x y + epsd--centerLabel :: ObjFnOn a-centerLabel [C' c, L' l] =- let [cx, cy, lx, ly] = [xc' c, yc' c, xl' l, yl' l] in- -- if dist (cx, cy) (lx, ly) > r' c then (cx - lx)^2 + (cy - ly)^2 else 0.3 *- (cx - lx)^2 + (cy - ly)^2-centerLabel [S' s, L' l] =- let [cx, cy, lx, ly] = [xs' s, ys' s, xl' l, yl' l] in- (cx - lx)^2 + (cy - ly)^2-centerLabel [P' p, L' l] =- let [px, py, lx, ly] = [xp' p, yp' p, xl' l, yl' l] in- (px + 10 - lx)^2 + (py + 20 - ly)^2 -- Top right from the point-centerLabel [A' a, L' l] =- let (sx, sy, ex, ey) = (startx' a, starty' a, endx' a, endy' a)- (mx, my) = midpoint (sx, sy) (ex, ey)- (lx, ly) = (xl' l, yl' l) in- (mx - lx)^2 + (my + 1.1 * hl' l - ly)^2 -- Top right from the point-centerLabel o = error ("centerLabel not called with 1 arg" ++ show o)--outside :: ObjFnOn a-outside [L' o, C' i] =- -- let d = dist (xl' o, yl' o) (xc' i, yc' i) in- -- if d > r' i then 0 else- -- (dist (xl' o, yl' o) (xc' i, yc' i) - (1.2 * r' i))^2- (dist (xl' o, yl' o) (xc' i, yc' i) - (1.2 * r' i))^2- -- (dist (xl' o, yl' o) (xc' i, yc' i) - (2 * r' i))^2-outside [L' o, S' i] =- (dist (xl' o, yl' o) (xs' i, ys' i) - 2 * (halfDiagonal . side') i)^2--------- Ambient objective functions---- -- no names specified; can apply to any combination of objects in M.Map--- type AmbientObjFn a = forall a. (Floating a, Real a, Show a, Ord a) => M.Map Name (Obj' a) -> a------ -- if there are no circles, doesn't do anything--- -- TODO fix in case there's only 1 circle?--- circParams :: (Floating a, Real a, Show a, Ord a) => M.Map Name (Obj' a) -> ([a], [a])--- circParams m = unpackSplit $ filter isCirc $ M.elems m--- where isCirc (C' _) = True--- isCirc _ = False------ -- reuse existing objective function--- circlesCenterAndRepel :: AmbientObjFn a--- circlesCenterAndRepel objMap = let (fix, vary) = circParams objMap in--- centerAndRepel_dist fix vary------ circlesCenter :: AmbientObjFn a--- circlesCenter objMap = let (fix, vary) = circParams objMap in--- centerObjs fix vary---- pairwiseRepel :: [Obj] -> Float--- pairwiseRepel objs = sumMap pairRepel $ allPairs objs---- pairRepel :: Obj -> Obj -> Float--- pairRepel c d = 1 / (distsq c d)--- where distsq c d = (getX c - getX d)^2 + (getY c - getY c)^2---- -- returns a list of ambient constraint fns--4 for each object--- -- i guess i don’t NEED to weight each individually. just sum them and weight the whole thing--- allInBbox :: [Obj] -> Float--- allInBbox objs = sum $ concatMap inBbox objs--- where inBbox o = [boxleft o, boxright o, boxup o, boxdown o]--- boxleft o = getX o - leftline -- magnitude of violation--------- Constraints--- Constraints are written WRT magnitude of violation--- TODO metaprogramming for boolean constraints--- TODO use these types?--- type ConstraintFn a = forall a. (Floating a, Real a, Show a, Ord a) => [Name] -> M.Map Name (Obj' a) -> a--defaultCWeight :: Floating a => a-defaultCWeight = 1---- TODO: should points also have a weight of 1?-defaultPWeight :: Floating a => a-defaultPWeight = 1-------------------------------------------------------------------------------------- Constraint functions--- List: smallerThan, contains, outsideOf, overlapping, nonOverlapping, samesize, maxsize, minsize-type ConstraintFn = forall a. (Floating a, Real a, Show a, Ord a) => [Obj' a] -> a--sameSize :: ConstraintFn-sameSize [S' s1, S' s2] = (side' s1 - side' s2)**2-sameSize [C' s1, C' s2] = (r' s1 - r' s2)**2--maxSize :: ConstraintFn-limit = max (fromIntegral 700) (fromIntegral 900)-maxSize [C' c] = r' c - limit / 3-maxSize [S' s] = side' s - limit / 3--minSize :: ConstraintFn-minSize [C' c] = 20 - r' c-minSize [S' s] = 20 - side' s--smallerThan :: ConstraintFn--- smallerThan [C' inc, C' outc] = (r' outc) - (r' inc) - 0.4 * r' outc -- TODO: taking this as a parameter?-smallerThan [C' inc, C' outc] = (r' inc) - (r' outc)-smallerThan [S' inc, S' outc] = (side' outc) - (side' inc) - subsetSizeDiff-smallerThan [C' c, S' s] = 0.5 * side' s - r' c-smallerThan [S' s, C' c] = r' c - (halfDiagonal . side') s--contains :: ConstraintFn-contains [C' outc, C' inc] =- -- tr (namec' outc ++ " contains " ++ namec' inc ++ " val: ") $- -- strictSubset [[xc' inc, yc' inc, r' inc], [xc' outc, yc' outc, r' outc]]- let res = dist (xc' inc, yc' inc) (xc' outc, yc' outc) - (r' outc - r' inc) in- if res > 0 then res else 0-contains [S' outc, S' inc] = strictSubset- [[xs' inc, ys' inc, 0.5 * side' inc], [xs' outc, ys' outc, 0.5 * side' outc]]-contains [S' outc, C' inc] = strictSubset- [[xc' inc, yc' inc, r' inc], [xs' outc, ys' outc, 0.5 * side' outc]]-contains [C' outc, S' inc] = strictSubset- [[xs' inc, ys' inc, (halfDiagonal . side') inc], [xc' outc, yc' outc, r' outc]]-contains [C' set, P' pt] =- dist (xp' pt, yp' pt) (xc' set, yc' set) - 0.5 * r' set-contains [S' set, P' pt] =- dist (xp' pt, yp' pt) (xs' set, ys' set) - 0.4 * side' set-contains [C' set, L' label] =- let res = dist (xl' label, yl' label) (xc' set, yc' set) - 0.5 * r' set in- if res < 0 then 0 else res-contains [S' set, L' label] =- dist (xl' label, yl' label) (xs' set, ys' set) - (side' set) / 2 + wl' label-contains _ = error "subset not called with 2 args"--outsideOf :: ConstraintFn-outsideOf [C' inc, C' outc] =- noSubset [[xc' inc, yc' inc, r' inc], [xc' outc, yc' outc, r' outc]]-outsideOf [S' inc, S' outc] =- noSubset [[xs' inc, ys' inc, (halfDiagonal . side') inc],- [xs' outc, ys' outc, (halfDiagonal . side') outc]]-outsideOf [C' inc, S' outs] =- noSubset [[xc' inc, yc' inc, r' inc], [xs' outs, ys' outs, (halfDiagonal . side') outs]]-outsideOf [S' inc, C' outc] =- noSubset [[xs' inc, ys' inc, (halfDiagonal . side') inc], [xc' outc, yc' outc, r' outc]]-outsideOf [P' pt, C' set] =- -dist (xp' pt, yp' pt) (xc' set, yc' set) + r' set-outsideOf [P' pt, S' set] =- -dist (xp' pt, yp' pt) (xs' set, ys' set) + (halfDiagonal . side') set-outsideOf [L' lout, C' inset] =- let labelR = max (wl' lout) (hl' lout)- res = - dist (xl' lout, yl' lout) (xc' inset, yc' inset) + r' inset + labelR in- if namel' lout == (labelName $ namec' inset) then 0 else res- -- if res <= 0 then 1 / res else res- -- - dist (xl' lout, yl' lout) (xc' inset, yc' inset) + r' inset-outsideOf [L' lout, S' inset] =- - dist (xl' lout, yl' lout) (xs' inset, ys' inset) + (halfDiagonal . side') inset-outsideOf _ = error "noSubset not called with 2 args"--overlapping :: ConstraintFn-overlapping [C' xset, C' yset] =- looseIntersect [[xc' xset, yc' xset, r' xset], [xc' yset, yc' yset, r' yset]]-overlapping [S' xset, C' yset] =- looseIntersect [[xs' xset, ys' xset, 0.5 * side' xset], [xc' yset, yc' yset, r' yset]]-overlapping [C' xset, S' yset] =- looseIntersect [[xc' xset, yc' xset, r' xset], [xs' yset, ys' yset, 0.5 * side' yset]]-overlapping [S' xset, S' yset] =- looseIntersect [[xs' xset, ys' xset, 0.5 * side' xset], [xs' yset, ys' yset, 0.5 * side' yset]]-overlapping _ = error "intersect not called with 2 args"--nonOverlapping :: ConstraintFn-nonOverlapping [C' xset, C' yset] =- noIntersectExt [[xc' xset, yc' xset, r' xset], [xc' yset, yc' yset, r' yset]]-nonOverlapping [S' xset, C' yset] =- noIntersectExt [[xs' xset, ys' xset, (halfDiagonal . side') xset], [xc' yset, yc' yset, r' yset]]-nonOverlapping [C' xset, S' yset] =- noIntersectExt [[xc' xset, yc' xset, r' xset], [xs' yset, ys' yset, (halfDiagonal . side') yset]]-nonOverlapping [S' xset, S' yset] =- noIntersectExt [[xs' xset, ys' xset, (halfDiagonal . side') xset],- [xs' yset, ys' yset, (halfDiagonal . side') yset]]-nonOverlapping [A' arr, L' label] =- let (sx, sy, ex, ey, t) = (startx' arr, starty' arr, endx' arr, endy' arr, thickness' arr)- (x1, y1, x2, y2) = (sx, sy - t, ex, ey + t)- dx = maximum [x1 - xl' label, 0, xl' label - x2]- dy = maximum [y1 - yl' label, 0, yl' label - y2] in- tr "labelvsArr: " $ -sqrt(dx**2 + dy**2) - wl' label-nonOverlapping _ = error "no intersect not called with 2 args"--type PairConstrV a = forall a . (Floating a, Ord a, Show a) => [[a]] -> a -- takes pairs of "packed" objs---noConstraint :: PairConstrV a-noConstraint _ = 0---- To convert your inequality constraint into a violation to be penalized:--- it needs to be in the form "c < 0" and c is the violation penalized if > 0--- so e.g. if you want "x < -100" then you would convert it to "x + 100 < 0" with c = x + 100--- if you want "f x > -100" then you would convert it to "-(f x + 100) < 0" with c = -(f x + 100)"---- all sets must pairwise-strict-intersect--- plus an offset so they overlap by a visible amount (perhaps this should be an optimization parameter?)-looseIntersect :: PairConstrV a-looseIntersect [[x1, y1, s1], [x2, y2, s2]] = let offset = 10 in- -- if s1 + s2 < offset then error "radii too small" --TODO: make it const- -- else- dist (x1, y1) (x2, y2) - (s1 + s2 - offset)---- the energy actually increases so it always settles around the offset--- that's because i am centering all of them--test w/objective off--- TODO flatten energy afterward, or get it to be *far* from the other set--- offset so the sets differ by a visible amount-noSubset :: PairConstrV a-noSubset [[x1, y1, s1], [x2, y2, s2]] = let offset = 10 in -- max/min dealing with s1 > s2 or s2 < s1- -(dist (x1, y1) (x2, y2)) + max s2 s1 - min s2 s1 + offset---- the first set is the subset of the second, and thus smaller than the second in size.--- TODO: test for equal sets--- TODO: for two primitives we have 4 functions, which is not sustainable. NOT NEEDED, remove them.-strictSubset :: PairConstrV a-strictSubset [[x1, y1, s1], [x2, y2, s2]] = dist (x1, y1) (x2, y2) - (s2 - s1)---- exterior point method constraint: no intersection (meaning also no subset)-noIntersectExt :: PairConstrV a-noIntersectExt [[x1, y1, s1], [x2, y2, s2]] = -(dist (x1, y1) (x2, y2)) + s1 + s2 + offset where offset = 10--pointInExt :: PairConstrV a-pointInExt [[x1, y1], [x2, y2, r]] = dist (x1, y1) (x2, y2) - 0.5 * r--pointNotInExt :: PairConstrV a-pointNotInExt [[x1, y1], [x2, y2, r]] = - dist (x1, y1) (x2, y2) + r---- exterior point method: penalty function-penalty :: (Ord a, Floating a, Show a) => a -> a-penalty x = (max x 0) ^ q -- weights should get progressively larger in cr_dist- where q = 2 -- also, may need to sample OUTSIDE feasible set- -- where q = 3 -- also, may need to sample OUTSIDE feasible set+-- {-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK prune #-}++module Functions where++import Utils+import System.Random+import Debug.Trace+import Shapes+import Transforms+import Data.Aeson (toJSON)+import Data.Maybe (fromMaybe)+import Data.Fixed (mod')+import Data.List (nub, sort, findIndex, find, maximumBy)+import System.Random.Shuffle+import qualified Data.Map.Strict as M+import qualified Data.MultiMap as MM++default (Int, Float) -- So we don't default to Integer, which is 10x slower than Int (?)++-- genShapeType $ shapeTypes shapeDefs+-- deriving instance Show ShapeType++debugOpt = True++trOpt :: Show a => String -> a -> a+trOpt s x = if debugOpt then trace "---" $ trace s $ traceShowId x else x++--------------------------------------------------------------------------------++type FuncName = String+type OptSignatures = MM.MultiMap String [ArgType]+-- TODO: should computations be overloaded?+type CompSignatures = M.Map String ([ArgType], ArgType)++type OptFn a = [ArgVal a] -> a+type ObjFnOn a = [ArgVal a] -> a+type ConstrFnOn a = [ArgVal a] -> a+type CompFnOn a = [ArgVal a] -> StdGen -> (ArgVal a, StdGen)+type ObjFn = forall a. (Autofloat a) => [ArgVal a] -> a+type ConstrFn = forall a. (Autofloat a) => [ArgVal a] -> a+type CompFn = forall a. (Autofloat a) => [ArgVal a] -> StdGen -> (ArgVal a, StdGen)++-- | computations that do not use randomization+type ConstCompFn = forall a. (Autofloat a) => [ArgVal a] -> ArgVal a++-- TODO: are the Info types still needed?+type Weight a = a+type ObjFnInfo a = (ObjFnOn a, Weight a, [Value a])+type ConstrFnInfo a = (ConstrFnOn a, Weight a, [Value a])+data FnInfo a = ObjFnInfo a | ConstrFnInfo a++-- TODO: the functions can just be looked up and checked once, don't need to repeat+invokeOptFn :: (Autofloat a) =>+ M.Map String (OptFn a) -> FuncName -> [ArgVal a] -> OptSignatures -> a+invokeOptFn dict n args signatures =+ let sigs = case signatures MM.! n of+ [] -> noSignatureError n+ l -> l+ args' = checkArgsOverload args sigs n+ f = fromMaybe (noFunctionError n) (M.lookup n dict)+ in f args+ -- in f args'++-- For a very limited form of supertyping...+linelike :: Autofloat a => Shape a -> Bool+linelike shape = fst shape == "Line" || fst shape == "Arrow"++--------------------------------------------------------------------------------+-- Computations+-- compDict :: forall a. (Autofloat a) => M.Map String (CompFnOn a)+compDict :: (Autofloat a) => M.Map String (CompFnOn a)+compDict = M.fromList+ [+ ("rgba", constComp rgba),+ ("atan", constComp arctangent),+ ("calcVectorsAngle", constComp calcVectorsAngle),+ ("calcVectorsAngleWithOrigin", constComp calcVectorsAngleWithOrigin),+ ("generateRandomReal", constComp generateRandomReal),+ ("calcNorm", constComp calcNorm),+ ("bboxWidth", constComp bboxWidth),+ ("bboxHeight", constComp bboxHeight),+ ("intersectionX", constComp intersectionX),+ ("intersectionY", constComp intersectionY),+ ("midpointX", constComp midpointX),+ ("midpointY", constComp midpointY),+ ("average", constComp average),+ ("len", constComp len),+ ("computeSurjectionLines", computeSurjectionLines),+ ("lineLeft", constComp lineLeft),+ ("lineRight", constComp lineRight),+ ("interpolate", constComp interpolate),+ ("sampleFunction", sampleFunction),+ ("fromDomain", fromDomain),+ ("applyFn", constComp applyFn),+ ("norm_", constComp norm_), -- type: any two GPIs with centers (getX, getY)+ ("midpointPathX", constComp midpointPathX),+ ("midpointPathY", constComp midpointPathY),+ ("sizePathX", constComp sizePathX),+ ("sizePathY", constComp sizePathY),+ ("makeRegionPath", constComp makeRegionPath),+ ("sampleFunctionArea", sampleFunctionArea),+ ("makeCurve", makeCurve),+ ("triangle", constComp triangle),+ ("shared", constComp sharedP),+ ("angle", constComp angleOf),+ ("perpX", constComp perpX),+ ("perpY", constComp perpY),+ ("perpPath", constComp perpPath),+ ("get", constComp get'),+ ("projectAndToScreen", constComp projectAndToScreen),+ ("projectAndToScreen_list", constComp projectAndToScreen_list),+ ("scaleLinear", constComp scaleLinear'),+ ("slerp", constComp slerp'),+ ("mod", constComp modSty),+ ("halfwayPoint", constComp halfwayPoint'),+ ("normalOnSphere", constComp normalOnSphere'),+ ("arcPath", constComp arcPath'),+ ("angleBisector", constComp angleBisector'),++ ("tangentLineSX", constComp tangentLineSX),+ ("tangentLineSY", constComp tangentLineSY),+ ("tangentLineEX", constComp tangentLineEX),+ ("tangentLineEY", constComp tangentLineEY),+ ("polygonizeCurve", constComp polygonizeCurve),+ ("setOpacity", constComp setOpacity),+ ("bbox", constComp bbox'),+ ("min", constComp min'),+ ("max", constComp max'),+ ("pathFromPoints", constComp pathFromPoints),+ ("join", constComp joinPath),++ -- Transformations+ ("rotate", constComp rotate),+ ("rotateAbout", constComp rotateAbout),+ ("scale", constComp scale),+ ("translate", constComp translate),+ ("andThen", constComp andThen),+ ("transformSRT", constComp transformSRT),+ ("mkPoly", constComp mkPoly),+ ("unitSquare", constComp unitSquare),+ ("unitCircle", constComp unitCircle),+ ("testTriangle", constComp testTri),+ ("testNonconvexPoly", constComp testNonconvexPoly),+ ("randomPolygon", randomPolygon),++ ("midpoint", noop), -- TODO+ ("sampleMatrix", noop), -- TODO+ ("sampleReal", noop), -- TODO+ ("sampleVectorIn", noop), -- TODO+ ("intersection", noop), -- TODO+ ("determinant", noop), -- TODO+ ("apply", noop) -- TODO+ ] -- TODO: port existing comps++compSignatures :: CompSignatures+compSignatures = M.fromList+ [+ ("rgba",+ ([ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT],+ ValueT ColorT)),+ ("atan",([ValueT FloatT],ValueT FloatT)),+ ("calcVectorsAngle",([ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT,+ ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT],ValueT FloatT)),+ ("calcVectorsAngleCos",([ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT,+ ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT],ValueT FloatT)),+ ("calcVectorsAngleWithOrigin",([ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT,+ ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT],ValueT FloatT)),+ ("generateRandomReal",([],ValueT FloatT)),+ ("calcNorm",([ValueT FloatT, ValueT FloatT, ValueT FloatT, ValueT FloatT],ValueT FloatT)),+ ("intersectionX", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT)),+ ("intersectionY", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT)),+ ("bboxHeight", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT)),+ ("bboxWidth", ([GPIType "Arrow", GPIType "Arrow"], ValueT FloatT)),+ ("len", ([GPIType "Arrow"], ValueT FloatT)),+ ("computeSurjectionLines", ([ValueT IntT, GPIType "Line", GPIType "Line", GPIType "Line", GPIType "Line"], ValueT PtListT)),+ ("lineLeft", ([ValueT FloatT, GPIType "Arrow", GPIType "Arrow"], ValueT PtListT)),+ ("interpolate", ([ValueT PtListT, ValueT StrT], ValueT PathDataT)),+ ("sampleFunction", ([ValueT IntT, AnyGPI, AnyGPI], ValueT PtListT)),+ ("midpointX", ([AnyGPI], ValueT FloatT)),+ ("midpointY", ([AnyGPI], ValueT FloatT)),+ ("fromDomain", ([ValueT PtListT], ValueT FloatT)),+ ("applyFn", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)),+ ("norm_", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)), -- type: any two GPIs with centers (getX, getY)+ ("midpointPathX", ([ValueT PtListT], ValueT FloatT)),+ ("midpointPathY", ([ValueT PtListT], ValueT FloatT)),+ ("sizePathX", ([ValueT PtListT], ValueT FloatT)),+ ("sizePathY", ([ValueT PtListT], ValueT FloatT)),+ ("tangentLineSX", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)),+ ("tangentLineSY", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)),+ ("tangentLineEX", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)),+ ("tangentLineEY", ([ValueT PtListT, ValueT FloatT], ValueT FloatT)),+ ("makeRegionPath", ([GPIType "Curve", GPIType "Line"], ValueT PathDataT))+ -- ("len", ([GPIType "Arrow"], ValueT FloatT))+ -- ("bbox", ([GPIType "Arrow", GPIType "Arrow"], ValueT StrT)), -- TODO+ -- ("sampleMatrix", ([], ValueT StrT)), -- TODO+ -- ("sampleVectorIn", ([], ValueT StrT)), -- TODO+ -- ("intersection", ([], ValueT StrT)), -- TODO+ -- ("determinant", ([], ValueT StrT)), -- TODO+ -- ("apply", ([], ValueT StrT)) -- TODO+ ]++invokeComp :: (Autofloat a) =>+ FuncName -> [ArgVal a] -> CompSignatures -> StdGen+ -> (ArgVal a, StdGen)+invokeComp n args sigs g =+ -- TODO: Improve computation function typechecking to allow for genericity #164+ let -- (argTypes, retType) =+ -- fromMaybe (noSignatureError n) (M.lookup n compSignatures)+ -- args' = checkArgs args argTypes n+ f = fromMaybe (noFunctionError n) (M.lookup n compDict)+ (ret, g') = f args g+ in (ret, g')+ -- if checkReturn ret retType then (ret, g') else+ -- error ("invalid return value \"" ++ show ret ++ "\" of computation \"" ++ show n ++ "\". expected type is \"" ++ show retType ++ "\"")++-- | 'constComp' is a wrapper for computation functions that do not use randomization+constComp :: ConstCompFn -> CompFn+constComp f = \args g -> (f args, g) -- written in the lambda fn style to be more readable++--------------------------------------------------------------------------------+-- Objectives++-- Weights+repelWeight :: (Autofloat a) => a+repelWeight = 10000000++-- | 'objFuncDict' stores a mapping from the name of objective functions to the actual implementation+objFuncDict :: forall a. (Autofloat a) => M.Map String (ObjFnOn a)+objFuncDict = M.fromList+ [+ ("near", near),+ ("center", center),+ ("centerX", centerX),+ ("centerLabel", centerLabel),+ ("centerArrow", centerArrow),+ ("repel", (*) repelWeight . repel),+ ("nearHead", nearHead),+ ("topRightOf", topRightOf),+ ("nearEndVert", nearEndVert),+ ("nearEndHoriz", nearEndHoriz),+ ("topLeftOf", topLeftOf),+ ("above", above),+ ("equal", equal),+ ("distBetween", distBetween),+ ("sameCenter", sameCenter),++ -- With the new transforms+ ("nearT", nearT),+ ("boundaryIntersect", boundaryIntersect),++ ("containsPoly", containsPoly),+ ("disjointPoly", disjointPoly),+ ("containsPolyPad", containsPolyPad),+ ("disjointPolyPad", disjointPolyPad),+ ("padding", padding),++ ("containAndTangent", containAndTangent),+ ("disjointAndTangent", disjointAndTangent),+ ("containsPolyOfs", containsPolyOfs),+ ("disjointPolyOfs", disjointPolyOfs),++ ("polyOnCanvas", polyOnCanvas),+ ("maximumSize", maximumSize),+ ("minimumSize", minimumSize),+ ("sameSize", sameSize),+ ("smaller", smaller),++ ("atPoint", atPoint),+ ("atPoint2", atPoint2),+ ("nearPoint", nearPoint),+ ("nearPoint2", nearPoint2),+ ("alignAlong", alignAlong),+ ("orderAlong", orderAlong)++ -- ("sameX", sameX)+{- ("centerLine", centerLine),+ ("increasingX", increasingX),+ ("increasingY", increasingY),+ ("horizontal", horizontal),+ ("upright", upright),+ ("xInRange", xInRange),+ ("yInRange", yInRange),+ ("orthogonal", orthogonal),+ ("toLeft", toLeft),+ ("between", between),+ ("ratioOf", ratioOf),+ ("sameY", sameY),+ -- ("sameX", (*) 0.6 `compose2` sameX),+ -- ("sameX", (*) 0.2 `compose2` sameX),+ ("repel", (*) 900000 `compose2` repel),+ -- ("repel", (*) 1000000 `compose2` repel),+ -- ("repel", (*) 10000 `compose2` repel),+ -- ("repel", repel),+ ("outside", outside),+ -}+ ]++objSignatures :: OptSignatures+objSignatures = MM.fromList+ [+ ("near", [GPIType "Circle", GPIType "Circle"]),+ ("near", [GPIType "Image", GPIType "Text", ValueT FloatT, ValueT FloatT]),+ ("nearHead",+ [GPIType "Arrow", GPIType "Text", ValueT FloatT, ValueT FloatT]),+ ("center", [AnyGPI]),+ ("centerX", [ValueT FloatT]),+ ("repel", [AnyGPI, AnyGPI]),+ ("centerLabel", [AnyGPI, GPIType "Text"]),+ ("centerArrow", [GPIType "Arrow", GPIType "Square", GPIType "Square"]),+ ("centerArrow", [GPIType "Arrow", GPIType "Circle", GPIType "Circle"]),+ ("centerArrow", [GPIType "Arrow", GPIType "Text", GPIType "Text"]),+ ("topLeftOf", [GPIType "Text", GPIType "Square"]),+ ("topLeftOf", [GPIType "Text", GPIType "Rectangle"]),+ ("topRightOf", [GPIType "Text", GPIType "Square"]),+ ("topRightOf", [GPIType "Text", GPIType "Rectangle"]),+ ("nearEndVert", [GPIType "Line", GPIType "Text"]),+ ("nearEndHoriz", [GPIType "Line", GPIType "Text"])+ -- ("centerArrow", []) -- TODO+ ]+++--------------------------------------------------------------------------------+-- Constraints++-- exterior point method: penalty function+penalty :: (Ord a, Floating a, Show a) => a -> a+penalty x = max x 0 ^ q -- weights should get progressively larger in cr_dist+ where q = 2 :: Int -- also, may need to sample OUTSIDE feasible set+ -- where q = 3+{-# INLINE penalty #-}++-- | 'constrFuncDict' stores a mapping from the name of constraint functions to the actual implementation+constrFuncDict :: forall a. (Autofloat a) => M.Map FuncName (ConstrFnOn a)+constrFuncDict = M.fromList $ map toPenalty flist+ where+ toPenalty (n, f) = (n, penalty . f)+ flist =+ [+ ("at", at),+ ("contains", contains),+ ("sameHeight", sameHeight),+ ("nearHead", nearHead),+ ("smallerThan", smallerThan),+ ("minSize", minSize),+ ("maxSize", maxSize),+ ("outsideOf", outsideOf),+ ("overlapping", overlapping),+ ("disjoint", disjoint),+ ("inRange", (*) indivConstrWeight . inRange'),+ ("lessThan", lessThan),+ ("onCanvas", onCanvas),+ ("unit", unit'),+ ("hasNorm", hasNorm)+ ]++indivConstrWeight :: (Autofloat a) => a+indivConstrWeight = 1++constrSignatures :: OptSignatures+constrSignatures = MM.fromList+ [+ ("at", [AnyGPI, ValueT FloatT, ValueT FloatT]),+ ("minSize", [AnyGPI]),+ ("maxSize", [AnyGPI]),+ ("smallerThan", [GPIType "Circle", GPIType "Circle"]),+ ("smallerThan", [GPIType "Circle", GPIType "Square"]),+ ("smallerThan", [GPIType "Square", GPIType "Circle"]),+ ("smallerThan", [GPIType "Square", GPIType "Square"]),+ ("outsideOf", [GPIType "Text", GPIType "Circle"]),+ ("contains", [GPIType "Circle", GPIType "Circle"]),+ ("contains", [GPIType "Square", GPIType "Arrow"]),+ ("contains", [GPIType "Circle", GPIType "Circle", ValueT FloatT]),+ ("contains", [GPIType "Circle", GPIType "Text"]),+ ("contains", [GPIType "Square", GPIType "Text"]),+ ("contains", [GPIType "Rectangle", GPIType "Text"]),+ ("contains", [GPIType "Square", GPIType "Circle", ValueT FloatT]),+ ("contains", [GPIType "Square", GPIType "Circle"]),+ ("contains", [GPIType "Circle", GPIType "Square"]),+ ("contains", [GPIType "Circle", GPIType "Rectangle"]),+ ("overlapping", [GPIType "Circle", GPIType "Circle"]),+ ("overlapping", [GPIType "Square", GPIType "Circle"]),+ ("overlapping", [GPIType "Circle", GPIType "Square"]),+ ("overlapping", [GPIType "Square", GPIType "Square"]),+ ("disjoint", [GPIType "Circle", GPIType "Circle"]),+ ("disjoint", [GPIType "Square", GPIType "Square"])+ -- ("lessThan", []) --TODO+ ]++--------------------------------------------------------------------------------+-- Type checker for objectives and constraints++checkArg :: (Autofloat a) => ArgVal a -> ArgType -> Bool+-- TODO: add warnings/errors (?)+checkArg (GPI _) AnyGPI = True+checkArg _ AnyGPI = False+checkArg (GPI (t, _)) (OneOf l) = t `elem` l+checkArg (GPI (t1, _)) (GPIType t2) = t1 == t2+checkArg (Val v) (ValueT t) = typeOf v == t+checkArg _ _ = False++matchWith args sig = length args == length sig && and (zipWith checkArg args sig)++checkArgs :: (Autofloat a) => [ArgVal a] -> [ArgType] -> String -> [ArgVal a]+checkArgs arguments signature n =+ if arguments `matchWith` signature+ then arguments+ else sigMismatchError n signature arguments++checkArgsOverload :: (Autofloat a) => [ArgVal a] -> [[ArgType]] -> String -> [ArgVal a]+checkArgsOverload arguments signatures n =+ if any (arguments `matchWith`) signatures+ then arguments+ else noMatchedSigError n signatures arguments++checkReturn :: (Autofloat a) => ArgVal a -> ArgType -> Bool+-- TODO: add warning+checkReturn ret@(Val v) (ValueT t) = typeOf v == t+checkReturn (GPI v) _ = error "checkReturn: Computations cannot return GPIs"++--------------------------------------------------------------------------------+-- Computation Functions++type Interval = (Float, Float)++-- Generate n random values uniformly randomly sampled from interval and return generator.+-- NOTE: I'm not sure how backprop works WRT randomness, so the gradients might be inconsistent here.+-- Interval is not polymorphic because I want to avoid using the Random typeclass (Random a)+ -- which causes type inference problems in Style for some reason.+-- Also apparently using Autofloat here with typeable causes problems for generality of returned StdGen.+-- But it works fine without Typeable.+randomsIn :: (Autofloat a) => StdGen -> Integer -> Interval -> ([a], StdGen)+randomsIn g 0 _ = ([], g)+randomsIn g n interval = let (x, g') = randomR interval g -- First value+ (xs, g'') = randomsIn g' (n - 1) interval in -- Rest of values+ (r2f x : xs, g'')++sampleFunction :: CompFn+-- Assuming domain and range are lines or arrows, TODO deal w/ points+-- TODO: discontinuous functions? not sure how to sample/model/draw consistently+sampleFunction [Val (IntV n), GPI domain, GPI range] g =+ let (dsx, dsy, dex, dey) = (getNum domain "startX", getNum domain "startY",+ getNum domain "endX", getNum domain "endY")+ (rsx, rsy, rex, rey) = (getNum range "startX", getNum range "startY",+ getNum range "endX", getNum range "endY")+ lower_left = (min dsx dex, min rsy rey)+ top_right = (max dsx dex, max rsy rey)+ (pts, g') = computeSurjection g n lower_left top_right+ in (Val $ PtListV pts, g')++-- Computes the surjection to lie inside a bounding box defined by the corners of a box+-- defined by four straight lines, assuming their lower/left coordinates come first.+-- Their intersections give the corners.+computeSurjectionLines :: CompFn+computeSurjectionLines args g =+ let (pts, g') = computeSurjectionLines' g args+ in (Val $ PtListV pts, g')++computeSurjectionLines' :: (Autofloat a) => StdGen -> [ArgVal a] -> ([Pt2 a], StdGen)+computeSurjectionLines' g args@[Val (IntV n), GPI left@("Line", _), GPI right@("Line", _), GPI bottom@("Line", _), GPI top@("Line", _)] =+ let lower_left = (getNum left "startX", getNum bottom "startY") in+ let top_right = (getNum right "startX", getNum top "startY") in+ computeSurjection g n lower_left top_right+-- Assuming left and bottom are perpendicular and share one point+computeSurjectionLines' g [Val (IntV n), GPI left@("Arrow", _), GPI bottom@("Arrow", _)] =+ let lower_left = (getNum left "startX", getNum left "startY") in+ let top_right = (getNum bottom "endX", getNum left "endY") in+ computeSurjection g n lower_left top_right++computeSurjection :: Autofloat a => StdGen -> Integer -> Pt2 a -> Pt2 a -> ([Pt2 a], StdGen)+computeSurjection g numPoints (lowerx, lowery) (topx, topy) =+ if numPoints < 2 then error "Surjection needs to have >= 2 points"+ else+ let (xs_inner, g') = randomsIn g (numPoints - 2) (r2f lowerx, r2f topx)+ xs = lowerx : xs_inner ++ [topx] -- Include endpts so function covers domain+ xs_increasing = sort xs+ (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f lowery, r2f topy)+ ys = lowery : ys_inner ++ [topy] -- Include endpts so function is onto+ ys_perm = shuffle' ys (length ys) g'' -- Random permutation. TODO return g3?+ -- in (zip xs_increasing ys_perm, g'') -- len xs == len ys+ in (zip xs_increasing ys_perm, g'')-- len xs == len ys++-- calculates a line (of two points) intersecting the first axis, stopping before it leaves bbox of second axis+-- TODO rename lineLeft and lineRight+-- assuming a1 horizontal and a2 vertical, respectively+lineLeft :: ConstCompFn+lineLeft [Val (FloatV lineFrac), GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =+ let a1_start = getNum a1 "startX" in+ let a1_len = abs (getNum a1 "endX" - a1_start) in+ let xpos = a1_start + lineFrac * a1_len in+ Val $ PtListV [(xpos, getNum a1 "startY"), (xpos, getNum a2 "endY")]++-- assuming a1 vert and a2 horiz, respectively+-- can this be written in terms of lineLeft?+lineRight :: ConstCompFn+lineRight [Val (FloatV lineFrac), GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =+ let a1_start = getNum a1 "startY" in+ let a1_len = abs (getNum a1 "endY" - a1_start) in+ let ypos = a1_start + lineFrac * a1_len in+ Val $ PtListV [(getNum a2 "startX", ypos), (getNum a2 "endX", ypos)]++rgba :: ConstCompFn+rgba [Val (FloatV r), Val (FloatV g), Val (FloatV b), Val (FloatV a)] =+ Val (ColorV $ makeColor' r g b a)++arctangent :: ConstCompFn+arctangent [Val (FloatV d)] = Val (FloatV $ (atan d) / pi * 180)++calcVectorsAngle :: ConstCompFn+calcVectorsAngle [Val (FloatV sx1), Val (FloatV sy1), Val (FloatV ex1),+ Val (FloatV ey1), Val (FloatV sx2), Val (FloatV sy2),+ Val (FloatV ex2), Val (FloatV ey2)] =+ let (ax,ay) = (ex1 - sx1, ey1 - sy1)+ (bx,by) = (ex2 - sx2, ey2 - sy2)+ ab = ax*bx + ay*by+ na = sqrt (ax^2 + ay^2)+ nb = sqrt (bx^2 + by^2)+ angle = acos (ab / (na*nb)) / pi*180.0+ in Val (FloatV angle)++calcVectorsAngleWithOrigin :: ConstCompFn+calcVectorsAngleWithOrigin [Val (FloatV sx1), Val (FloatV sy1), Val (FloatV ex1),+ Val (FloatV ey1), Val (FloatV sx2), Val (FloatV sy2),+ Val (FloatV ex2), Val (FloatV ey2)] =+ let (ax,ay) = (ex1 - sx1, ey1 - sy1)+ (bx,by) = (ex2 - sx2, ey2 - sy2)+ (cx,cy) = ((ax + bx)/2.0,(ay + by)/2.0)+ angle = if cy < 0 then (atan (cy / cx) / pi*180.0) * 2.0 else 180.0 + (atan (cy / cx) / pi*180.0) * 2.0+ in Val (FloatV $ -1.0 * angle)+ -- angle1 = if ay < 0 then (atan (ay / ax) / pi*180.0) else 180.0 + (atan (ay / ax) / pi*180.0)+ -- angle2 = if by < 0 then (atan (by / bx) / pi*180.0) else 180.0 + (atan (by / bx) / pi*180.0)+ -- in if traceShowId angle1 > traceShowId angle2 then Val (FloatV $ -1 * angle1) else Val (FloatV $ -1 * angle2)++generateRandomReal :: ConstCompFn+generateRandomReal [] = let g1 = mkStdGen 16+ (x,g2) = (randomR (1, 15) g1) :: (Int,StdGen)+ y = fst(randomR (1, 15) g2) :: Int+ in Val (FloatV ((fromIntegral x)/(fromIntegral y)))++calcNorm :: ConstCompFn+calcNorm [Val (FloatV sx1), Val (FloatV sy1), Val (FloatV ex1),Val (FloatV ey1)] =+ let nx = (ex1 - sx1) ** 2.0+ ny = (ey1 - sy1) ** 2.0+ norm = sqrt (nx + ny + 0.5)+ in Val (FloatV norm)++linePts, arrowPts :: (Autofloat a) => Shape a -> (a, a, a, a)+linePts = arrowPts+arrowPts a = (getNum a "startX", getNum a "startY", getNum a "endX", getNum a "endY")++infinity :: Floating a => a+infinity = 1/0 -- x/0 == Infinity for any x > 0 (x = 0 -> Nan, x < 0 -> -Infinity)++intersectionX :: ConstCompFn+intersectionX [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =+ let (x0, y0, x1, y1) = arrowPts a1+ (x2, y2, x3, y3) = arrowPts a2+ det = (x0 - x1) * (y2 - y3) - (y0 - y1) * (x2 - x3)+ in Val $ FloatV $+ if det == 0 then infinity+ else (x0*y1 - y0*x1)*(x2 - x3) - (x0 - x1)*(x2*x3 - y2*y3) / det+intersectionY :: ConstCompFn+intersectionY [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =+ let (x0, y0, x1, y1) = arrowPts a1+ (x2, y2, x3, y3) = arrowPts a2+ det = (x0 - x1) * (y2 - y3) - (y0 - y1) * (x2 - x3)+ in Val $ FloatV $+ if det == 0 then infinity+ else (x0*y1 - y0*x1)*(x2 - x3) - (y0 - y1)*(x2*x3 - y2*y3) / det++len :: ConstCompFn+len [GPI a@("Arrow", _)] =+ let (x0, y0, x1, y1) = arrowPts a+ in Val $ FloatV $ dist (x0, y0) (x1, y1)++midpointX :: ConstCompFn+midpointX [GPI l] =+ if linelike l+ then let (x0, x1) = (getNum l "startX", getNum l "endX")+ in Val $ FloatV $ (x1 + x0) / 2+ else error "GPI type must be line-like"++midpointY :: ConstCompFn+midpointY [GPI l] =+ if linelike l+ then let (y0, y1) = (getNum l "startY", getNum l "endY")+ in Val $ FloatV $ (y1 + y0) / 2+ else error "GPI type must be line-like"++average :: ConstCompFn+average [Val (FloatV x), Val (FloatV y)] =+ let res = (x + y) / 2+ in Val $ FloatV res++norm_ :: ConstCompFn+norm_ [Val (FloatV x), Val (FloatV y)] = Val $ FloatV $ norm [x, y]++-- | Catmull-Rom spline interpolation algorithm+interpolateFn :: Autofloat a => [Pt2 a] -> [Elem a]+interpolateFn pts =+ let k = 1.5+ p0 = head pts+ chunks = repeat4 $ head pts : pts ++ [last pts]+ paths = map (chain k) chunks+ finalPath = Pt p0 : paths+ in finalPath+ where repeat4 xs = [ take 4 . drop n $ xs | n <- [0..length xs - 4] ]++-- Wrapper for interpolateFn+interpolate :: ConstCompFn+interpolate [Val (PtListV pts)] =+ let pathRes = interpolateFn pts+ in Val $ PathDataV $ [Open pathRes]++chain :: Autofloat a => a -> [(a, a)] -> Elem a+chain k [(x0, y0), (x1, y1), (x2, y2), (x3, y3)] =+ let cp1x = x1 + (x2 - x0) / 6 * k+ cp1y = y1 + (y2 - y0) / 6 * k+ cp2x = x2 - (x3 - x1) / 6 * k+ cp2y = y2 - (y3 - y1) / 6 * k+ in CubicBez ((cp1x, cp1y), (cp2x, cp2y), (x2, y2))++-- COMBAK: finish this+-- sampleCurve :: Autofloat a =>+-- StdGen -> Integer -> Pt2 a -> Pt2 a -> Bool -> Bool -> [Pt2 a]+-- sampleCurve g numPoints (lowerx, lowery) (topx, topy) =+-- if numPoints < 2 then error "Surjection needs to have >= 2 points"+-- else+-- let (xs_inner, g') = randomsIn g (numPoints - 2) (r2f lowerx, r2f topx)+-- xs = lowerx : xs_inner ++ [topx] -- Include endpts so function covers domain+-- (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f lowery, r2f topy)+-- ys = lowery : ys_inner ++ [topy] -- Include endpts so function is onto+-- xs_increasing = sort xs+-- ys_perm = shuffle' ys (length ys) g'' -- Random permutation. TODO return g3?+-- -- in (zip xs_increasing ys_perm, g'') -- len xs == len ys+-- in zip xs_increasing ys_perm -- len xs == len ys++-- From Shapes.hs, TODO factor out+sampleList :: (Autofloat a) => [a] -> StdGen -> (a, StdGen)+sampleList list g =+ let (idx, g') = randomR (0, length list - 1) g+ in (list !! idx, g')++-- sample random element from domain of function (relation)+fromDomain :: CompFn+fromDomain [Val (PtListV path)] g =+ let (x, g') = sampleList (middle $ map fst path) g in+ -- let x = fst $ path !! 1 in+ (Val $ FloatV x, g')+ where middle = init . tail++-- lookup element in function (relation) by making a Map+applyFn :: ConstCompFn+applyFn [Val (PtListV path), Val (FloatV x)] =+ case M.lookup x (M.fromList path) of+ Just y -> Val (FloatV y)+ Nothing -> error "x element does not exist in function"++-- TODO: remove the unused functions in the next four+midpointPathX :: ConstCompFn+midpointPathX [Val (PtListV path)] =+ let xs = map fst path+ res = (maximum xs + minimum xs) / 2 in+ Val $ FloatV res++midpointPathY :: ConstCompFn+midpointPathY [Val (PtListV path)] =+ let ys = map snd path+ res = (maximum ys + minimum ys) / 2 in+ Val $ FloatV res++sizePathX :: ConstCompFn+sizePathX [Val (PtListV path)] =+ let xs = map fst path+ res = maximum xs - minimum xs in+ Val $ FloatV res++sizePathY :: ConstCompFn+sizePathY [Val (PtListV path)] =+ let ys = map snd path+ res = maximum ys - minimum ys in+ Val $ FloatV res++-- Compute path for an integral's shape (under a function, above the interval on which the function is defined)+makeRegionPath :: ConstCompFn+makeRegionPath [GPI fn@("Curve", _), GPI intv@("Line", _)] =+ let pt1 = Pt $ getPoint "start" intv+ pt2 = Pt $ getPoint "end" intv+ -- Assume the function is a single open path consisting of a Pt elem, followed by CubicBez elements+ -- (i.e. produced by `interpolate` with parameter "open")+ curve = case (getPathData fn) !! 0 of+ Open elems -> elems+ Closed elems -> error "makeRegionPath not implemented for closed paths"+ path = Closed $ pt1 : curve ++ [pt2]+ in Val (PathDataV [path])++-- Make determinant region+makeRegionPath [GPI a1, GPI a2] =+ if not (linelike a1 && linelike a2) then error "expected two linelike GPIs" else+ let xs@[sx1, ex1, sx2, ex2] = getXs a1 ++ getXs a2+ ys@[sy1, ey1, sy2, ey2] = getYs a1 ++ getYs a2+ -- Third coordinate is the vector addition, normalized for an origin that may not be (0, 0)+ regionPts = [(sx1, sy1), (ex1, ey1), (ex1 + ex2 - sx1, ey1 + ey2 - sy1), (ex2, ey2)]+ path = Closed $ map Pt regionPts+ in Val (PathDataV [path])+ where getXs a = [getNum a "startX", getNum a "endX"]+ getYs a = [getNum a "startY", getNum a "endY"]++-- | Draws a filled region from domain to range with in-curved sides, assuming domain is above range+-- | Directionality: domain's right, then range's right, then range's left, then domain's left++-- TODO: when range's x is a lot smaller than the domain's x, or |range| << |domain|, the generated region crosses itself+-- You can see this by adjusting the interval size by *dragging the labels*+-- TODO: should account for thickness of domain and range+-- Assuming horizontal GPIs+sampleFunctionArea :: CompFn+sampleFunctionArea [x@(GPI domain), y@(GPI range)] g =+ -- Apply with default offsets+ sampleFunctionArea [x, y, Val (FloatV 0.3), Val (FloatV 0.0)] g+sampleFunctionArea [GPI domain, GPI range, Val (FloatV xFrac), Val (FloatV yFrac)] g =+ if linelike domain && linelike range+ then let pt_tl = getPoint "start" domain+ pt_tr = getPoint "end" domain++ pt_br = getPoint "end" range+ pt_bl = getPoint "start" range++ -- Compute dx (the x offset for the function's shape) as a fraction of width of the smaller interval+ width = min (abs (fst pt_tl - fst pt_tr)) (abs (fst pt_br - fst pt_bl))+ height = abs $ snd pt_bl - snd pt_tl+ dx = xFrac * width+ dy = yFrac * height+ x_offset = (dx, 0)+ y_offset = (0, dy)+ pt_midright = midpoint pt_tr pt_br -: x_offset +: y_offset+ pt_midleft = midpoint pt_bl pt_tl +: x_offset +: y_offset++ right_curve = interpolateFn [pt_tr, pt_midright, pt_br]+ left_curve = interpolateFn [pt_bl, pt_midleft, pt_tl]++ -- TODO: not sure if this is right. do any points need to be included in the path?+ path = Closed $ [Pt pt_tl, Pt pt_tr] ++ right_curve ++ [Pt pt_br, Pt pt_bl] ++ left_curve+ in (Val $ PathDataV [path], g)+ else error "expected two linelike shapes"++-- Draw a curve from (x1, y1) to (x2, y2) with some point in the middle defining curvature+makeCurve :: CompFn+makeCurve [Val (FloatV x1), Val (FloatV y1), Val (FloatV x2), Val (FloatV y2), Val (FloatV dx), Val (FloatV dy)] g =+ let offset = (dx, dy)+ midpt = midpoint (x1, y1) (x2, y2) +: offset+ path = Open $ interpolateFn [(x1, y1), midpt, (x2, y2)]+ in (Val $ PathDataV [path], g)++-- Draw a triangle as the closure of three lines (assuming they define a valid triangle, i.e. intersect exactly at their endpoints)+triangle :: ConstCompFn+triangle [Val (FloatV x1), Val (FloatV y1), Val (FloatV x2), Val (FloatV y2), Val (FloatV x3), Val (FloatV y3)] =+ let path = Closed [Pt (x1, y1), Pt (x2, y2), Pt (x3, y3)]+ in Val $ PathDataV [path]++triangle [GPI e1@("Line", _), GPI e2@("Line", _), GPI e3@("Line", _)] =+ -- TODO: what's the convention on the ordering of the lines?+ let (v1, v2) = (getPoint "start" e1, getPoint "end" e1)+ v3_candidates = [getPoint "start" e2, getPoint "end" e2,+ getPoint "start" e3, getPoint "end" e3]+ v3 = furthestFrom (v1, v2) v3_candidates+ path = Closed [Pt v1, Pt v2, Pt v3]+ in {- trace ("path: " ++ show path) $ -} Val $ PathDataV [path]+ where+ furthestFrom :: (Autofloat a) => (Pt2 a, Pt2 a) -> [Pt2 a] -> Pt2 a+ furthestFrom (p1, p2) pts = fst $+ maximumBy (\p1 p2 -> compare (snd p1) (snd p2)) $+ map (\p -> (p, dist p p1 + dist p p2)) pts++sharedP :: ConstCompFn+sharedP [Val (FloatV a), Val (FloatV b), Val (FloatV c), Val (FloatV d)] =+ let xs = nub [a, b, c, d]+ common = case xs of+ [] -> error "no shared points between segments"+ x:xs -> x+ in Val $ FloatV common++angleOf :: ConstCompFn+angleOf [GPI l@("Line", _), Val (FloatV originX), Val (FloatV originY)] =+ let origin = (originX, originY)+ (start, end) = (getPoint "start" l, getPoint "end" l)+ endpoint = if origin == start then end else start -- Pick the point that's not the origin+ (rayX, rayY) = endpoint -: origin+ angleRad = atan2 rayY rayX+ angle = (angleRad * 180) / pi+ in Val $ FloatV angle++perp :: Autofloat a => Pt2 a -> Pt2 a -> Pt2 a -> a -> Pt2 a+perp start end base len = let dir = normalize' $ end -: start+ perpDir = (len *: (rot90 dir)) +: base+ in perpDir++perpX :: ConstCompFn+perpX [GPI l@("Line", _), Val (FloatV baseX), Val (FloatV baseY), Val (FloatV len)] =+ let (start, end) = (getPoint "start" l, getPoint "end" l)+ in Val $ FloatV $ fst $ perp start end (baseX, baseY) len++perpY :: ConstCompFn+perpY [GPI l@("Line", _), Val (FloatV baseX), Val (FloatV baseY), Val (FloatV len)] =+ let (start, end) = (getPoint "start" l, getPoint "end" l)+ in Val $ FloatV $ snd $ perp start end (baseX, baseY) len++perpPath :: ConstCompFn+perpPath [GPI r@("Line", _), GPI l@("Line", _), Val (FloatV size)] = -- Euclidean+ let (startR, endR) = (getPoint "start" r, getPoint "end" r)+ (startL, endL) = (getPoint "start" l, getPoint "end" l)+ dirR = normalize' $ endR -: startR+ dirL = normalize' $ endL -: startL+ ptL = startR +: (size *: dirL)+ ptR = startR +: (size *: dirR)+ ptLR = startR +: (size *: dirL) +: (size *: dirR)+ -- TODO: clean up this code+ path = Open $ [Pt ptL, Pt ptLR, Pt ptR]+ in Val $ PathDataV [path]++perpPath [Val (ListV p), Val (ListV q), Val (ListV tailv), Val (ListV headv), Val (FloatV arcLen)] = -- Spherical+ let (p', q') = (normalize p, normalize q) + -- TODO: cache these calculations bc they're recomputed many times in Ray, Triangle, etc.+ (e1, e2) = (p', normalize (p' `cross` q')) -- e2 is normal to (e1, e3)+ e3 = normalize (e2 `cross` e1)+ local_normal_normal = normalize (tailv `cross` headv) -- The normal to the plane defined by the (headv, tailv) vectors, which is tangent to (p,q) at the point tailv+ pt_along_seg = circPtInPlane tailv local_normal_normal arcLen -- Start at the tail of the ray and move along the segment (pq) using its tangent+ pt_along_normal = circPtInPlane tailv e2 arcLen -- Start at the tail of the ray and move along the ray in the direction normal to (pq)+ n = 20+ arc_parallel_to_normal = slerp n 0.0 arcLen pt_along_seg e2 -- Move from the segment point in the direction normal to (pq)+ arc_parallel_to_seg = slerp n 0.0 arcLen pt_along_normal local_normal_normal -- Move from the ray point in the direction normal to the ray+ -- Note that the directions are chosen so that the directionality of the arcs match so they meet at a point+ pts = arc_parallel_to_normal ++ (tail . reverse) arc_parallel_to_seg -- Drop a point so they join better+ in Val $ LListV pts++-- NOTE: assumes that the curve has at least 3 points+tangentLine :: Autofloat a => a -> [Pt2 a] -> a -> (Pt2 a, Pt2 a)+tangentLine x ptList len =+ let i = fromMaybe 1 $ findIndex (\(a, _) -> abs (x - a) <= 1) ptList+ p0@(px, py) = ptList !! i+ p1 = nextPoint p0 $ drop (i - 1) ptList+ k = slope p0 p1+ dx = d / sqrt (1 + k^2)+ dy = k * dx+ d = len / 2+ in ((px - dx, py - dy), (px + dx, py + dy))+ where+ -- NOTE: instead of getting the immediate next point in the list, we search the rest of the list until a point that is numerically far enough from (x, y) is found, in order to compute the slope.+ nextPoint (x, y) l = fromMaybe+ (error "tangentLine: cannot find next point") $+ find (\(x', y') -> abs (x - x') > epsd || abs (y - y') > epsd) l+ slope (x0, y0) (x1, y1) = (y1 - y0) / (x1 - x0)++tangentLineSX :: ConstCompFn+tangentLineSX [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =+ Val $ FloatV $ fst $ fst $ tangentLine x curve len+tangentLineSY :: ConstCompFn+tangentLineSY [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =+ Val $ FloatV $ snd $ fst $ tangentLine x curve len+tangentLineEX :: ConstCompFn+tangentLineEX [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =+ Val $ FloatV $ fst $ snd $ tangentLine x curve len+tangentLineEY :: ConstCompFn+tangentLineEY [Val (PtListV curve), Val (FloatV x), Val (FloatV len)] =+ Val $ FloatV $ snd $ snd $ tangentLine x curve len++polygonizeCurve :: ConstCompFn+polygonizeCurve [Val (IntV maxIter), Val (PathDataV curve)] =+ Val $ PtListV $ polygonizePath (fromIntegral maxIter) curve++bboxHeight :: ConstCompFn+bboxHeight [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =+ let ys@[y0, y1, y2, y3] = getYs a1 ++ getYs a2+ (ymin, ymax) = (minimum ys, maximum ys)+ in Val $ FloatV $ abs $ ymax - ymin+ where getYs a = [getNum a "startY", getNum a "endY"]++bboxWidth :: ConstCompFn+bboxWidth [GPI a1@("Arrow", _), GPI a2@("Arrow", _)] =+ let xs@[x0, x1, x2, x3] = getXs a1 ++ getXs a2+ (xmin, xmax) = (minimum xs, maximum xs)+ in Val $ FloatV $ abs $ xmax - xmin+ where getXs a = [getNum a "startX", getNum a "endX"]++bbox :: (Autofloat a) => Shape a -> Shape a -> [(a, a)]+bbox a1 a2 =+ if not (linelike a1 && linelike a2) then error "expected two linelike GPIs" else+ let xs@[x0, x1, x2, x3] = getXs a1 ++ getXs a2+ (xmin, xmax) = (minimum xs, maximum xs)+ ys@[y0, y1, y2, y3] = getYs a1 ++ getYs a2+ (ymin, ymax) = (minimum ys, maximum ys)+ -- Four bbox points in clockwise order (bottom left, bottom right, top right, top left)+ in [(xmin, ymin), (xmax, ymin), (xmax, ymax), (xmin, ymax)]+ where getXs a = [getNum a "startX", getNum a "endX"]+ getYs a = [getNum a "startY", getNum a "endY"]++bbox' :: ConstCompFn+bbox' [GPI a1, GPI a2] = Val $ PtListV $ bbox a2 a2++min' :: ConstCompFn+min' [Val (FloatV x), Val (FloatV y)] = Val $ FloatV $ min x y++max' :: ConstCompFn+max' [Val (FloatV x), Val (FloatV y)] = Val $ FloatV $ max x y++noop :: CompFn+noop [] g = (Val (StrV "TODO"), g)++-- Set the opacity to a given fraction of the value.+setOpacity :: ConstCompFn+setOpacity [Val (ColorV (RGBA r g b a)), Val (FloatV frac)] = Val $ ColorV (RGBA r g b (r2f frac * a))++----------++get' :: ConstCompFn+get' [Val (ListV xs), Val (IntV i)] =+ let i' = (fromIntegral i) :: Int in+ if i' < 0 || i' >= length xs then error "out of bounds access in get'"+ else Val $ FloatV $ xs !! i'+get' [Val (TupV (x1, x2)), index] = get' [Val (ListV [x1, x2]), index]++projectVec :: Autofloat a => String -> Pt2 a -> Pt2 a -> a -> [a] -> [a] -> [a] -> a -> [a]+projectVec name hfov vfov r camera dir vec_math toScreen =+ let vec_camera = vec_math -. camera -- Camera at origin. TODO: rotate with dir+ [px, py, pz] = vec_camera+ vec_proj = (1 / pz) *. [px, py]+ vec_screen = toScreen *. vec_proj+ vec_proj_screen = vec_screen ++ [pz] -- TODO check denom 0. Also note z might be negative?+ in trace ("\n"+ ++ "name: " ++ name+ ++ "\nvec_math: " ++ show vec_math+ ++ "\n||vec_math||: " ++ show (norm vec_math)+ ++ "\nvec_camera: " ++ show vec_camera+ ++ "\nvec_proj: " ++ show vec_proj+ ++ "\nvec_screen: " ++ show vec_screen+ ++ "\nvec_proj_screen: " ++ show vec_proj_screen ++ "\n")+ vec_proj_screen++-- | For two points p, q, the easiest thing is to form an orthonormal basis e1=p, e2=(p x q)/|p x q|, e3=e2 x e1, then draw the arc as cos(t)e1 + sin(t)e3 for t between 0 and arccos(p . q) (Assuming p and q are unit)+slerp' :: ConstCompFn+slerp' [Val (ListV p), Val (ListV q), Val (IntV n)] = -- Assuming unit p, q?+ let (e1, e2) = (normalize p, normalize (p `cross` q)) -- (e1, e3) span the plane of p and q+ e3 = normalize (e2 `cross` e1)+ (t0, t1) = (0.0, angleBetweenRad p q) -- On a unit sphere, the angle between points is the length of the arc b/t them+ pts = slerp (fromIntegral n) t0 t1 e1 e3+ in Val $ LListV $+ trace ("(e1, e2, e3): " ++ show (e1, e2, e3)+ ++ "\ndot results: " ++ show [ei `dotL` ej | ei <- [e1, e2, e3], ej <- [e1, e2, e3]]+ ++ "\n(p, q, angleBetweenRad): " ++ show (p, q, t1)+ ++ "\npts: " ++ show pts)+ pts++-- TODO: how does this behave with negative numbers?+modSty :: ConstCompFn+modSty [Val (FloatV x), Val (FloatV m)] = Val $ FloatV $ (x `mod'` m) -- Floating mod++-- http://mathworld.wolfram.com/SphericalCoordinates.html+projectAndToScreen :: ConstCompFn+projectAndToScreen [Val (TupV hfov), Val (TupV vfov), Val (FloatV r),+ Val (ListV camera), Val (ListV dir),+ Val (ListV vec_math), Val (FloatV toScreen), Val (StrV name)] =+ Val $ ListV $ projectVec name hfov vfov r camera dir vec_math toScreen++projectAndToScreen_list :: ConstCompFn+projectAndToScreen_list [Val (TupV hfov), Val (TupV vfov), Val (FloatV r),+ Val (ListV camera), Val (ListV dir),+ Val (LListV spherePath), Val (FloatV toScreen), Val (StrV name)] =+ Val $ PtListV $ (map (\vmath -> let res = projectVec name hfov vfov r camera dir vmath toScreen+ in (res !! 0, res !! 1)) spherePath)+ -- Discard z-coordinate for now++halfwayPoint' :: ConstCompFn -- Based off slerp'+halfwayPoint' [Val (ListV p), Val (ListV q)] =+ let (p', q') = (normalize p, normalize q)+ (e1, e2) = (p', normalize (p' `cross` q'))+ e3 = normalize (e2 `cross` e1)+ t = (angleBetweenRad p' q') / 2.0 -- Half the angle, or half the arc length+ r = circPtInPlane e1 e3 t+ in Val (ListV r)++normalOnSphere' :: ConstCompFn+normalOnSphere' [Val (ListV p), Val (ListV q), Val (ListV tailv), Val (FloatV arcLen)] =+ let normalv = normalize (p `cross` q)+ headv = circPtInPlane (normalize tailv) normalv arcLen -- Start at tailv (point on segment), move in normal direction by arcLen+ in Val (ListV headv)++-- Draw the arc on the sphere between the segment (pq) and the segment (qr) with some fixed radius+-- The angle between lines (pq, pr) is angle of the planes containing the great circles of the arcs+-- Find an orthonormal basis with the normal (n) of the sphere at a point, then the tangent vectors (t1, t2) of the plane at the point, where t1 is in the direction of one of the lines+-- t1 is found as `p - proj_q(p) |> normalize` (where p is the local origin and q is another point on the triangle)+-- Then draw the arc in the tangent plane from t1 to the angle, then translate it to the local origin+arcPath' :: ConstCompFn+arcPath' [Val (ListV p), Val (ListV q), Val (ListV r), Val (FloatV radius)] = -- Radius is arc len+ let normal = p+ (qp, rp) = (q -. p, r -. p)+ (qp_normal, rp_normal) = (q `cross` p, r `cross` p)+ theta = angleBetweenSigned normal qp_normal rp_normal -- The signed angle from qp normal to rp normal (in the tangent plane defined by `p`, where `p` is the normal that points outward from the sphere+ t1 = normalize (qp -. (proj normal qp)) -- tangent in qp direction+ t2 = t1 `cross` normal+ n = 20+ pts_origin = map (radius *.) $ slerp n 0 theta t1 t2 -- starts at qp segment+ pts = map (+. p) pts_origin -- Why does this arc lie on the sphere?+ in Val $ LListV pts++-- TODO: share some code betwen this and arcPath'?+angleBisector' :: ConstCompFn+angleBisector' [Val (ListV p), Val (ListV q), Val (ListV r), Val (FloatV radius)] = -- Radius is arc len+ let normal = p+ (qp, rp) = (q -. p, r -. p)+ (qp_normal, rp_normal) = (q `cross` p, r `cross` p)+ theta = (angleBetweenSigned normal qp_normal rp_normal) / 2.0+ t1 = normalize (qp -. (proj normal qp)) -- tangent in qp direction+ t2 = t1 `cross` normal+ pt_origin = (p +.) $ (radius *.) $ circPtInPlane t1 t2 theta -- starts at qp segment+ in Val $ ListV pt_origin++scaleLinear' :: ConstCompFn+scaleLinear' [Val (FloatV x), Val (TupV range), Val (TupV range')] =+ Val $ FloatV $ scaleLinear x range range'++pathFromPoints :: ConstCompFn+pathFromPoints [Val (PtListV pts)] =+ let path = Open $ map Pt pts+ in Val $ PathDataV [path]++joinPath :: ConstCompFn+joinPath [Val (PtListV pq), Val (PtListV qr), Val (PtListV rp)] =+ let path = Closed $ map Pt $ pq ++ qr ++ rp+ in Val $ PathDataV [path]++--------------------------------------------------------------------------------+-- Objective Functions++near :: ObjFn+near [GPI o, Val (FloatV x), Val (FloatV y)] = distsq (getX o, getY o) (x, y)+near [GPI o1, GPI o2] = distsq (getX o1, getY o1) (getX o2, getY o2)+near [GPI o1, GPI o2, Val (FloatV offset)] = distsq (getX o1, getY o1) (getX o2, getY o2) - offset^2+near [GPI img@("Image", _), GPI lab@("Text", _), Val (FloatV xoff), Val (FloatV yoff)] =+ let center = (getNum img "centerX", getNum img "centerY")+ offset = (xoff, yoff)+ in distsq (getX lab, getY lab) (center `plus2` offset)+ where plus2 (a, b) (c, d) = (a + c, b + d)++center :: ObjFn+center [GPI o] = tr "center: " $ distsq (getX o, getY o) (0, 0)++centerX :: ObjFn+centerX [Val (FloatV x)] = tr "centerX" $ x^2++-- | 'sameCenter' encourages two objects to center at the same point+sameCenter :: ObjFn+sameCenter [GPI a, GPI b] = (getX a - getX b)^2 + (getY a - getY b)^2++centerLabel :: ObjFn+centerLabel [a, b, Val (FloatV w)] = w * centerLabel [a, b] -- TODO factor out+-- TODO revert+-- centerLabel [GPI curve, GPI text]+-- | curve `is` "Curve" && text `is` "Text" =+-- let ((lx, ly), (rx, ry)) = bezierBbox curve+-- (xmargin, ymargin) = (-10, 30)+-- midbez = ((lx + rx) / 2 + xmargin, (ly + ry) / 2 + ymargin) in+-- distsq midbez (getX text, getY text)+centerLabel [GPI p, GPI l]+ | p `is` "AnchorPoint" && l `is` "Text" =+ let [px, py, lx, ly] = [getX p, getY p, getX l, getY l] in+ (px + 10 - lx)^2 + (py + 20 - ly)^2 -- Top right from the point+-- -- TODO: depends on orientation of arrow+centerLabel [GPI arr, GPI text]+ | ((arr `is` "Arrow") || (arr `is` "Line")) && text `is` "Text" =+ let (sx, sy, ex, ey) = (getNum arr "startX", getNum arr "startY", getNum arr "endX", getNum arr "endY")+ (mx, my) = midpoint (sx, sy) (ex, ey)+ (lx, ly) = (getX text, getY text) in+ (mx - lx)^2 + (my + 1.1 * getNum text "h" - ly)^2 -- Top right from the point+centerLabel [a, b] = sameCenter [a, b]+-- centerLabel [CB' a, L' l] [mag] = -- use the float input?+-- let (sx, sy, ex, ey) = (startx' a, starty' a, endx' a, endy' a)+-- (mx, my) = midpoint (sx, sy) (ex, ey)+-- (lx, ly) = (xl' l, yl' l) in+ -- (mx - lx)^2 + (my + 1.1 * hl' l - ly)^2 -- Top right from the point++-- | `centerArrow` positions an arrow between two objects, with some spacing+centerArrow :: ObjFn+centerArrow [GPI arr@("Arrow", _), GPI sq1@("Square", _), GPI sq2@("Square", _)] =+ _centerArrow arr [getX sq1, getY sq1] [getX sq2, getY sq2]+ [spacing + (halfDiagonal . flip getNum "side") sq1, negate $ spacing + (halfDiagonal . flip getNum "side") sq2]++centerArrow [GPI arr@("Arrow", _), GPI sq@("Square", _), GPI circ@("Circle", _)] =+ _centerArrow arr [getX sq, getY sq] [getX circ, getY circ]+ [spacing + (halfDiagonal . flip getNum "side") sq, negate $ spacing + getNum circ "radius"]++centerArrow [GPI arr@("Arrow", _), GPI circ@("Circle", _), GPI sq@("Square", _)] =+ _centerArrow arr [getX circ, getY circ] [getX sq, getY sq]+ [spacing + getNum circ "radius", negate $ spacing + (halfDiagonal . flip getNum "side") sq]++centerArrow [GPI arr@("Arrow", _), GPI circ1@("Circle", _), GPI circ2@("Circle", _)] =+ _centerArrow arr [getX circ1, getY circ1] [getX circ2, getY circ2]+ [ spacing * getNum circ1 "r", negate $ spacing * getNum circ2 "r"]++centerArrow [GPI arr@("Arrow", _), GPI ell1@("Ellipse", _), GPI ell2@("Ellipse", _)] =+ _centerArrow arr [getX ell1, getY ell1] [getX ell2, getY ell2]+ [ spacing * getNum ell1 "radius1", negate $ spacing * getNum ell2 "radius2"]+ -- FIXME: inaccurate, only works for horizontal cases++centerArrow [GPI arr@("Arrow", _), GPI pt1@("AnchorPoint", _), GPI pt2@("AnchorPoint", _)] =+ _centerArrow arr [getX pt1, getY pt1] [getX pt2, getY pt2]+ [ spacing * 2 * r2f ptRadius, negate $ spacing * 2 * r2f ptRadius]+ -- FIXME: anchor points have no radius++centerArrow [GPI arr@("Arrow", _), GPI text1@("Text", _), GPI text2@("Text", _)] =+ _centerArrow arr [getX text1, getY text1] [getX text2, getY text2]+ [spacing * getNum text1 "h", negate $ 2 * spacing * getNum text2 "h"]++centerArrow [GPI arr@("Arrow", _), GPI text@("Text", _), GPI circ@("Circle", _)] =+ _centerArrow arr [getX text, getY text] [getX circ, getY circ]+ [1.5 * getNum text "w", negate $ spacing * getNum circ "radius"]++spacing :: (Autofloat a) => a+spacing = 1.1 -- TODO: arbitrary++_centerArrow :: Autofloat a => Shape a -> [a] -> [a] -> [a] -> a+_centerArrow arr@("Arrow", _) s1@[x1, y1] s2@[x2, y2] [o1, o2] =+ let vec = [x2 - x1, y2 - y1] -- direction the arrow should point to+ dir = normalize vec+ [sx, sy, ex, ey] = if norm vec > o1 + abs o2+ then (s1 +. o1 *. dir) ++ (s2 +. o2 *. dir) else s1 ++ s2+ [fromx, fromy, tox, toy] = [getNum arr "startX", getNum arr "startY",+ getNum arr "endX", getNum arr "endY"] in+ (fromx - sx)^2 + (fromy - sy)^2 + (tox - ex)^2 + (toy - ey)^2++-- | 'repel' exert an repelling force between objects+-- TODO: temporarily written in a generic way+-- Note: repel's energies are quite small so the function is scaled by repelWeight before being applied+repel :: ObjFn+repel [Val (TupV x), Val (TupV y)] = 1 / (distsq x y + epsd)+repel [GPI a, GPI b] = 1 / (distsq (getX a, getY a) (getX b, getY b) + epsd)+repel [GPI a, GPI b, Val (FloatV weight)] = weight / (distsq (getX a, getY a) (getX b, getY b) + epsd)+ -- trace ("REPEL: " ++ show a ++ "\n" ++ show b ++ "\n" ++ show res) res+-- repel [C' c, S' d] [] = 1 / distsq (xc' c, yc' c) (xs' d, ys' d) - r' c - side' d + epsd+-- repel [S' c, C' d] [] = 1 / distsq (xc' d, yc' d) (xs' c, ys' c) - r' d - side' c + epsd+-- repel [P' c, P' d] [] = if c == d then 0 else 1 / distsq (xp' c, yp' c) (xp' d, yp' d) - 2 * r2f ptRadius + epsd+-- repel [L' c, L' d] [] = if c == d then 0 else 1 / distsq (xl' c, yl' c) (xl' d, yl' d)+-- repel [L' c, C' d] [] = 1 / distsq (xl' c, yl' c) (xc' d, yc' d)+-- repel [C' c, L' d] [] = 1 / distsq (xc' c, yc' c) (xl' d, yl' d)+-- repel [L' c, S' d] [] = 1 / distsq (xl' c, yl' c) (xs' d, ys' d)+-- repel [S' c, L' d] [] = 1 / distsq (xs' c, ys' c) (xl' d, yl' d)+-- repel [A' c, L' d] [] = repel' (startx' c, starty' c) (xl' d, yl' d) ++-- repel' (endx' c, endy' c) (xl' d, yl' d)+-- repel [A' c, C' d] [] = repel' (startx' c, starty' c) (xc' d, yc' d) ++-- repel' (endx' c, endy' c) (xc' d, yc' d)+-- repel [IM' c, IM' d] [] = 1 / (distsq (xim' c, yim' c) (xim' d, yim' d) + epsd) - sizeXim' c - sizeXim' d --TODO Lily check this math is correct+-- repel [a, b] [] = if a == b then 0 else 1 / (distsq (getX a, getY a) (getX b, getY b) )++topRightOf :: ObjFn+topRightOf [GPI l@("Text", _), GPI s@("Square", _)] = dist (getX l, getY l) (getX s + 0.5 * getNum s "side", getY s + 0.5 * getNum s "side")+topRightOf [GPI l@("Text", _), GPI s@("Rectangle", _)] = dist (getX l, getY l) (getX s + 0.5 * getNum s "sizeX", getY s + 0.5 * getNum s "sizeY")++topLeftOf :: ObjFn+topLeftOf [GPI l@("Text", _), GPI s@("Square", _)] = dist (getX l, getY l) (getX s - 0.5 * getNum s "side", getY s - 0.5 * getNum s "side")+topLeftOf [GPI l@("Text", _), GPI s@("Rectangle", _)] = dist (getX l, getY l) (getX s - 0.5 * getNum s "sizeX", getY s - 0.5 * getNum s "sizeY")++nearHead :: ObjFn+nearHead [GPI l, GPI lab@("Text", _), Val (FloatV xoff), Val (FloatV yoff)] =+ if linelike l+ then let end = (getNum l "endX", getNum l "endY")+ offset = (xoff, yoff)+ in distsq (getX lab, getY lab) (end `plus2` offset)+ else error "GPI type for nearHead must be line-like"+ where plus2 (a, b) (c, d) = (a + c, b + d)++nearEndVert :: ObjFn+-- expects a vertical line+nearEndVert [GPI line@("Line", _), GPI lab@("Text", _)] =+ let (sx, sy, ex, ey) = linePts line in+ let bottompt = if sy < ey then (sx, sy) else (ex, ey) in+ let yoffset = -25 in+ let res = distsq (getX lab, getY lab) (fst bottompt, snd bottompt + yoffset) in res++nearEndHoriz :: ObjFn+-- expects a horiz line+nearEndHoriz [GPI line@("Line", _), GPI lab@("Text", _)] =+ let (sx, sy, ex, ey) = linePts line in+ let leftpt = if sx < ex then (sx, sy) else (ex, ey) in+ let xoffset = -25 in+ distsq (getX lab, getY lab) (fst leftpt + xoffset, snd leftpt)++-- | 'above' makes sure the first argument is on top of the second.+above :: ObjFn+above [GPI top, GPI bottom, Val (FloatV offset)] = (getY top - getY bottom - offset)^2+above [GPI top, GPI bottom] = (getY top - getY bottom - 100)^2++-- | 'sameHeight' forces two objects to stay at the same height (have the same Y value)+sameHeight :: ObjFn+sameHeight [GPI a, GPI b] = (getY a - getY b)^2++equal :: ObjFn+equal [Val (FloatV a), Val (FloatV b)] = (a - b)^2++distBetween :: ObjFn+distBetween [GPI c1@("Circle", _), GPI c2@("Circle", _), Val (FloatV padding)] =+ let (r1, r2, x1, y1, x2, y2) = (getNum c1 "r", getNum c2 "r", getX c1, getY c1, getX c2, getY c2) in+ -- If one's a subset of another or has same radius as other+ -- If they only intersect+ if dist (x1, y1) (x2, y2) < (r1 + r2)+ then repel [GPI c1, GPI c2, Val (FloatV repelWeight)] -- 1 / distsq (x1, y1) (x2, y2)+ -- If they don't intersect+ else -- trace ("padding: " ++ show padding)+ (dist (x1, y1) (x2, y2) - r1 - r2 - padding)^2++--------------------------------------------------------------------------------+-- Constraint Functions++at :: ConstrFn+at [GPI o, Val (FloatV x), Val (FloatV y)] =+ (getX o - x)^2 + (getY o - y)^2++lessThan :: ConstrFn+lessThan [Val (FloatV x), Val (FloatV y)] =+ x - y++contains :: ConstrFn+contains [GPI o1@("Circle", _), GPI o2@("Circle", _)] =+ dist (getX o1, getY o1) (getX o2, getY o2) - (getNum o1 "r" - getNum o2 "r")+contains [GPI outc@("Circle", _), GPI inc@("Circle", _), Val (FloatV padding)] =+ dist (getX outc, getY outc) (getX inc, getY inc) - (getNum outc "r" - padding - getNum inc "r")+contains [GPI c@("Circle", _), GPI rect@("Rectangle", _)] =+ let (x, y, w, h) =+ (getX rect, getY rect, getNum rect "sizeX", getNum rect "sizeY")+ [x0, x1, y0, y1] = [x - w/2, x + w/2, y - h/2, y + h/2]+ pts = [(x0, y0), (x0, y1), (x1, y0), (x1, y1)]+ (cx, cy, radius) = (getX c, getY c, getNum c "r")+ in sum $ map (\(a, b) -> max 0 $ dist (cx, cy) (a, b) - radius) pts+contains [GPI c@("Circle", _), GPI t@("Text", _)] =+ let res = dist (getX t, getY t) (getX c, getY c) - getNum c "r" + max (getNum t "w") (getNum t "h")+ in if res < 0 then 0 else res+ -- TODO: factor out the vertex access code to a high-level getter+ -- NOTE: seems that the following version doesn't perform as well as the hackier old version. Maybe it's the shape of the obj that is doing it, but we do observe that the labels tend to get really close to the edges+ -- let (x, y, w, h) = (getX t, getY t, getNum t "w", getNum t "h")+ -- [x0, x1, y0, y1] = [x - w/2, x + w/2, y - h/2, y + h/2]+ -- pts = [(x0, y0), (x0, y1), (x1, y0), (x1, y1)]+ -- (cx, cy, radius) = (getX c, getY c, getNum c "r")+ -- in sum $ map (\(a, b) -> (max 0 $ dist (cx, cy) (a, b) - radius)^2) pts+contains [GPI s@("Square", _), GPI l@("Text", _)] =+ dist (getX l, getY l) (getX s, getY s) - getNum s "side" / 2 + getNum l "w" / 2+contains [GPI s@("Rectangle", _), GPI l@("Text", _)] =+ -- TODO: implement precisely, max (w, h)? How about diagonal case?+ dist (getX l, getY l) (getX s, getY s) - getNum s "sizeX" / 2 + getNum l "w" / 2+contains [GPI outc@("Square", _), GPI inc@("Square", _)] =+ dist (getX outc, getY outc) (getX inc, getY inc) - (0.5 * getNum outc "side" - 0.5 * getNum inc "side")+contains [GPI outc@("Square", _), GPI inc@("Circle", _)] =+ dist (getX outc, getY outc) (getX inc, getY inc) - (0.5 * getNum outc "side" - getNum inc "r")+contains [GPI outc@("Square", _), GPI inc@("Circle", _), Val (FloatV padding)] =+ dist (getX outc, getY outc) (getX inc, getY inc) - (0.5 * getNum outc "side" - padding - getNum inc "r")+contains [GPI outc@("Circle", _), GPI inc@("Square", _)] =+ dist (getX outc, getY outc) (getX inc, getY inc) - (getNum outc "r" - 0.5 * getNum inc "side")+contains [GPI set@("Ellipse", _), GPI label@("Text", _)] =+ dist (getX label, getY label) (getX set, getY set) - max (getNum set "r") (getNum set "r") + getNum label "w"+contains [GPI sq@("Square", _), GPI ar@("Arrow", _)] =+ let (startX, startY, endX, endY) = arrowPts ar+ (x, y) = (getX sq, getY sq)+ side = getNum sq "side"+ (lx, ly) = ((x - side / 2) * 0.75, (y - side / 2) * 0.75)+ (rx, ry) = ((x + side / 2) * 0.75, (y + side / 2) * 0.75)+ in inRange startX lx rx+ + inRange startY ly ry+ + inRange endX lx rx+ + inRange endY ly ry+contains [GPI rt@("Rectangle", _), GPI ar@("Arrow", _)] =+ let (startX, startY, endX, endY) = arrowPts ar+ (x, y) = (getX rt, getY rt)+ (w, h) = (getNum rt "sizeX", getNum rt "sizeY")+ (lx, ly) = (x - w / 2, y - h / 2)+ (rx, ry) = (x + w / 2, y + h / 2)+ in inRange startX lx rx+ + inRange startY ly ry+ + inRange endX lx rx+ + inRange endY ly ry++inRange a l r+ | a < l = (a-l)^2+ | a > r = (a-r)^2+ | otherwise = 0++inRange'' :: (Autofloat a) => a -> a -> a -> a+inRange'' v left right+ | v < left = left - v+ | v > right = v - right+ | otherwise = 0++inRange' :: ConstrFn+inRange' [Val (FloatV v), Val (FloatV left), Val (FloatV right)]+ | v < left = left - v+ | v > right = v - right+ | otherwise = 0+-- = inRange v left right++onCanvas :: ConstrFn+onCanvas [GPI g] =+ let (leftX, rightX) = (-canvasHeight / 2, canvasHeight / 2)+ (leftY, rightY) = (-canvasWidth / 2, canvasWidth / 2) in+ inRange'' (getX g) (r2f leftX) (r2f rightX) ++ inRange'' (getY g) (r2f leftY) (r2f rightY)++unit' :: ConstrFn+unit' [Val (ListV vec)] = hasNorm [Val (ListV vec), Val (FloatV 1)]++-- | This is an equality constraint (x = c) via two inequality constraints (x <= c and x >= c)+hasNorm :: ConstrFn+hasNorm [Val (ListV vec), Val (FloatV desired_norm)] =+ let norms = (norm vec, desired_norm) -- TODO: Use normal norm or normsq?+ (norm_max, norm_min) = (uncurry max norms, uncurry min norms)+ in norm_max - norm_min++-- contains [GPI set@("Circle", _), P' GPI pt@("", _)] = dist (getX pt, getX pt) (getX set, getY set) - 0.5 * r' set+-- TODO: only approx+-- contains [S' GPI set@("", _), P' GPI pt@("", _)] =+-- dist (getX pt, getX pt) (getX set, getX set) - 0.4 * side' set+-- FIXME: doesn't work+-- contains [E' GPI set@("", _), P' GPI pt@("", _)] =+-- dist (getX pt, getX pt) (xe' set, getX set) - max (rx' set) (ry' set) * 0.9++-- NOTE/HACK: all objects will have min/max size attached, but not all of them are implemented+maxSize :: ConstrFn+-- TODO: why do we need `r2f` now? Didn't have to before+limit = max canvasWidth canvasHeight+maxSize [GPI c@("Circle", _)] = getNum c "r" - r2f (limit / 6)+maxSize [GPI s@("Square", _)] = getNum s "side" - r2f (limit / 3)+maxSize [GPI r@("Rectangle", _)] =+ let max_side = max (getNum r "sizeX") (getNum r "sizeY")+ in max_side - r2f (limit / 3)+maxSize [GPI im@("Image", _)] =+ let max_side = max (getNum im "lengthX") (getNum im "lengthY")+ in max_side - r2f (limit / 3)+maxSize [GPI e@("Ellipse", _)] = max (getNum e "r") (getNum e "r") - r2f (limit / 3)+maxSize _ = 0++-- NOTE/HACK: all objects will have min/max size attached, but not all of them are implemented+minSize :: ConstrFn+minSize [GPI c@("Circle", _)] = 20 - getNum c "r"+minSize [GPI s@("Square", _)] = 20 - getNum s "side"+minSize [GPI r@("Rectangle", _)] =+ let min_side = min (getNum r "sizeX") (getNum r "sizeY")+ in 20 - min_side+minSize [GPI e@("Ellipse", _)] = 20 - min (getNum e "r") (getNum e "r")+minSize [GPI g] =+ if fst g == "Line" || fst g == "Arrow" then+ let vec = [ getNum g "endX" - getNum g "startX",+ getNum g "endY" - getNum g "startY"] in+ 50 - norm vec+ else 0+minSize [GPI g, Val (FloatV len)] =+ if fst g == "Line" || fst g == "Arrow" then+ let vec = [ getNum g "endX" - getNum g "startX",+ getNum g "endY" - getNum g "startY"] in+ len - norm vec+ else 0++smallerThan :: ConstrFn+smallerThan [GPI inc@("Circle", _), GPI outc@("Circle", _)] =+ getNum inc "r" - getNum outc "r" - 0.4 * getNum outc "r" -- TODO: taking this as a parameter?+smallerThan [GPI inc@("Circle", _), GPI outs@("Square", _)] =+ 0.5 * getNum outs "side" - getNum inc "r"+smallerThan [GPI ins@("Square", _), GPI outc@("Circle", _)] =+ halfDiagonal $ getNum ins "side" - getNum outc "r"+smallerThan [GPI ins@("Square", _), GPI outs@("Square", _)] =+ getNum ins "side" - getNum outs "side" - subsetSizeDiff++outsideOf :: ConstrFn+outsideOf [GPI l@("Text", _), GPI c@("Circle", _)] =+ let padding = 10.0 in+ let labelR = max (getNum l "w") (getNum l "h") in+ -dist (getX l, getY l) (getX c, getY c) + getNum c "r" + labelR + padding+-- TODO: factor out runtime weights+outsideOf [GPI l@("Text", _), GPI c@("Circle", _), Val (FloatV weight)] =+ weight * outsideOf [GPI l, GPI c]++overlapping :: ConstrFn+overlapping [GPI xset@("Circle", _), GPI yset@("Circle", _)] =+ looseIntersect [[getX xset, getY xset, getNum xset "r"], [getX yset, getY yset, getNum yset "r"]]+overlapping [GPI xset@("Square", _), GPI yset@("Circle", _)] =+ looseIntersect [[getX xset, getY xset, 0.5 * getNum xset "side"], [getX yset, getY yset, getNum yset "r"]]+overlapping [GPI xset@("Circle", _), GPI yset@("Square", _)] =+ looseIntersect [[getX xset, getY xset, getNum xset "r"], [getX yset, getY yset, 0.5 * getNum yset "side"]]+overlapping [GPI xset@("Square", _), GPI yset@("Square", _)] =+ looseIntersect [[getX xset, getY xset, 0.5 * getNum xset "side"], [getX yset, getY yset, 0.5 * getNum yset "side"]]++looseIntersect :: (Autofloat a) => [[a]] -> a+looseIntersect [[x1, y1, s1], [x2, y2, s2]] = dist (x1, y1) (x2, y2) - (s1 + s2 - 10)++disjoint :: ConstrFn+disjoint [GPI xset@("Circle", _), GPI yset@("Circle", _)] =+ noIntersect [[getX xset, getY xset, getNum xset "r"], [getX yset, getY yset, getNum yset "r"]]++-- This is not totally correct since it doesn't account for the diagonal of a square+disjoint [GPI xset@("Square", _), GPI yset@("Square", _)] =+ noIntersect [[getX xset, getY xset, 0.5 * getNum xset "side"], [getX yset, getY yset, 0.5 * getNum yset "side"]]++disjoint [GPI xset@("Rectangle", _), GPI yset@("Rectangle", _), Val (FloatV offset)] =+ -- Arbitrarily using x size+ noIntersectOffset [[getX xset, getY xset, 0.5 * getNum xset "sizeX"], [getX yset, getY yset, 0.5 * getNum yset "sizeX"]] offset++disjoint [GPI box@("Text", _), GPI seg@("Line", _), Val (FloatV offset)] =+ let center = (getX box, getY box)+ (v, w) = (getPoint "start" seg, getPoint "end" seg)+ cp = closestpt_pt_seg center (v, w)+ len_approx = getNum box "w" / 2.0 -- TODO make this more exact+ in -(dist center cp) + len_approx + offset+ -- i.e. dist from center of box to closest pt on line seg is greater than the approx distance between the box center and the line + some offset+++-- For horizontally collinear line segments only+-- with endpoints (si, ei), assuming si < ei (e.g. enforced by some other constraint)+-- Make sure the closest endpoints are separated by some padding+disjoint [GPI o1, GPI o2] =+ if linelike o1 && linelike o2 then+ let (start1, end1, start2, end2) =+ (fst $ getPoint "start" o1, fst $ getPoint "end" o1,+ fst $ getPoint "start" o2, fst $ getPoint "end" o2) -- Throw away y coords+ padding = 30 -- should be > 0+ -- Six cases for two intervals: disjoint [-] (-), overlap (-[-)-], contained [-(-)-], and swapping the intervals+ -- Assuming si < ei, we can just push away the closest start and end of the two intervals+ distA = unsignedDist end1 start2+ distB = unsignedDist end2 start1+ in if distA <= distB+ then end1 + padding - start2 -- Intervals separated by padding (original condition: e1 + c < s2)+ else end2 + padding - start1 -- e2 + c < s1+ else error "expected two linelike GPIs in `disjoint`"+ where unsignedDist :: (Autofloat a) => a -> a -> a+ unsignedDist x y = abs $ x - y++-- exterior point method constraint: no intersection (meaning also no subset)+noIntersect :: (Autofloat a) => [[a]] -> a+noIntersect [[x1, y1, s1], [x2, y2, s2]] = -(dist (x1, y1) (x2, y2)) + s1 + s2 + offset where offset = 10++noIntersectOffset :: (Autofloat a) => [[a]] -> a -> a+noIntersectOffset [[x1, y1, s1], [x2, y2, s2]] offset = -(dist (x1, y1) (x2, y2)) + s1 + s2 + offset++--------------------------------------------------------------------------------+-- Wrappers for transforms and operations to call from Style++-- NOTE: Haskell trig is in radians+rotate :: ConstCompFn+rotate [Val (FloatV radians)] = Val $ HMatrixV $ rotationM radians++rotateAbout :: ConstCompFn+rotateAbout [Val (FloatV angle), Val (FloatV x), Val (FloatV y)] =+ Val $ HMatrixV $ rotationAboutM angle (x, y)++translate :: ConstCompFn+translate [Val (FloatV x), Val (FloatV y)] = Val $ HMatrixV $ translationM (x, y)++scale :: ConstCompFn+scale [Val (FloatV cx), Val (FloatV cy)] = Val $ HMatrixV $ scalingM (cx, cy)++-- Apply transforms from left to right order: do t2, then t1+andThen :: ConstCompFn+andThen [Val (HMatrixV t2), Val (HMatrixV t1)] =+ Val $ HMatrixV $ composeTransform t1 t2++------ Sample shapes++-- TODO: parse lists of 2-tuples+mkPoly :: ConstCompFn+mkPoly [Val (FloatV x1), Val (FloatV x2), Val (FloatV x3),+ Val (FloatV x4), Val (FloatV x5), Val (FloatV x6)] =+ Val $ PtListV [(x1, x2), (x3, x4), (x5, x6)]+mkPoly [Val (FloatV x1), Val (FloatV x2), Val (FloatV x3),+ Val (FloatV x4), Val (FloatV x5), Val (FloatV x6), Val (FloatV x7), Val (FloatV x8)] =+ Val $ PtListV [(x1, x2), (x3, x4), (x5, x6), (x7, x8)]+mkPoly [Val (FloatV x1), Val (FloatV x2), Val (FloatV x3),+ Val (FloatV x4), Val (FloatV x5), Val (FloatV x6),+ Val (FloatV x7), Val (FloatV x8), Val (FloatV x9), Val (FloatV x10)] =+ Val $ PtListV [(x1, x2), (x3, x4), (x5, x6), (x7, x8), (x9, x10)]++unitSquare :: ConstCompFn+unitSquare [] = Val $ PtListV unitSq++unitCircle :: ConstCompFn+unitCircle [] = Val $ PtListV $ circlePoly 1.0 --unitCirc++testTri :: ConstCompFn+testTri [] = Val $ PtListV testTriangle++testNonconvexPoly :: ConstCompFn+testNonconvexPoly [] = Val $ PtListV testNonconvex++-- No guarantees about nonintersection, convexity, etc. Just a bunch of points in a range.+randomPolygon :: CompFn+randomPolygon [Val (IntV n)] g =+ let range = (-100, 100)+ (xs, g') = randomsIn g n range+ (ys, g'') = randomsIn g' n range+ pts = zip xs ys+ in (Val $ PtListV pts, g'')++------ Transform objectives and constraints++-- Optimize directly on the transform+-- this function is only a demo+nearT :: ObjFn+nearT [GPI o, Val (FloatV x), Val (FloatV y)] =+ let tf = getTransform o in+ distsq (dx tf, dy tf) (x, y)++boundaryIntersect :: ObjFn+boundaryIntersect [GPI o1, GPI o2] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ dsqGG p1 p2++containsPoly :: ObjFn+containsPoly [GPI o1, GPI o2] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eAcontainB p1 p2++disjointPoly :: ObjFn+disjointPoly [GPI o1, GPI o2] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eABdisj p1 p2++-- pad / padding: minimum amt of separation between two shapes' boundaries.+-- See more at energy definitions (eBinAPad, eBoutAPad, ePad, etc.)++containsPolyPad :: ObjFn+containsPolyPad [GPI o1, GPI o2, Val (FloatV ofs)] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eBinAPad p1 p2 ofs++disjointPolyPad :: ObjFn+disjointPolyPad [GPI o1, GPI o2, Val (FloatV ofs)] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eBoutAPad p1 p2 ofs++padding :: ObjFn+padding [GPI o1, GPI o2, Val (FloatV ofs)] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ ePad p1 p2 ofs++containAndTangent :: ObjFn+containAndTangent [GPI o1, GPI o2] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ (eAcontainB p1 p2) + (dsqGG p1 p2)++disjointAndTangent :: ObjFn+disjointAndTangent [GPI o1, GPI o2] =+ let (p1, p2) = (getPolygon o1, getPolygon o2) in+ (eABdisj p1 p2) + (dsqGG p1 p2)++-- ofs / offset: exact amt of separation between two shapes' boundaries.+-- See more at energy definitions (eBinAOffs, eBoutAOffs, eOffs, etc.)++containsPolyOfs :: ObjFn+containsPolyOfs [GPI o1, GPI o2, Val (FloatV ofs)] = + let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eBinAOffs p1 p2 ofs++disjointPolyOfs :: ObjFn+disjointPolyOfs [GPI o1, GPI o2, Val (FloatV ofs)] = + let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eBoutAOffs p1 p2 ofs++polyOnCanvas :: ObjFn+polyOnCanvas [GPI o] = let+ (halfw, halfh) = (r2f canvasWidth / 2, r2f canvasHeight / 2)+ canv = [(-halfw, -halfh), (halfw, -halfh), (halfw, halfh), (-halfw, halfh)]+ in eBinAPad (toPoly canv) (getPolygon o) 0++maximumSize :: ObjFn+maximumSize [GPI o, Val (FloatV s)] = eMaxSize (getPolygon o) s++minimumSize :: ObjFn+minimumSize [GPI o, Val (FloatV s)] = eMinSize (getPolygon o) s+++-- inputs: shape, p.x, p.y, target.x, target.y, +-- where p is some point in local coordinates of shape (ex: (0,0) is the center for most shapes), +-- and target is some coordinates on canvas (ex: (0,0) is the origin). +-- Encourages transformation to shape so that p is at the location of target.+atPoint :: ObjFn+atPoint [GPI o, Val (FloatV ox), Val (FloatV oy), Val (FloatV x), Val (FloatV y)] = let+ tf = getTransformation o+ in dsqPP (x,y) $ tf ## (ox,oy)++-- inputs: shape1, p1.x, p1.y, shape2, p2.x, p2.y, +-- where p1 is some point in local coordinates of shape1 (ex: (0,0) is the center for most shapes)+-- and p2 is some point in local coordinates of shape2. +-- Encourages transformation to both shapes so that p1 and p2 overlap.+atPoint2 :: ObjFn+atPoint2 [GPI o1, Val (FloatV x1), Val (FloatV y1), GPI o2, Val (FloatV x2), Val (FloatV y2)] = let+ tf1 = getTransformation o1+ tf2 = getTransformation o2+ in dsqPP (tf1 ## (x1,y1)) (tf2 ## (x2,y2))++-- inputs: shape, target.x, target.y, offset, +-- where target is some coordinates on canvas (ex: (0,0) is the origin). +-- Encourages transformation to shape so that its boundary becomes offset pixels away from target.+-- Could have many other versions of "near". +nearPoint :: ObjFn+nearPoint [GPI o, Val (FloatV x), Val (FloatV y), Val (FloatV ofs)] = let+ -- tf = getTransformation o+ in eOffsP (getPolygon o) (x,y) ofs++-- inputs: shape1, p1.x, p1.y, shape2, p2.x, p2.y, offset, +-- where p1 is some point in local coordinates of shape1 (ex: (0,0) is the center for most shapes)+-- and p2 is some point in local coordinates of shape2. +-- Encourages transformation to both shapes so that p1 and p2 are offset pixels apart.+nearPoint2 :: ObjFn+nearPoint2 [GPI o1, Val (FloatV x1), Val (FloatV y1), GPI o2, Val (FloatV x2), Val (FloatV y2), Val (FloatV ofs)] = let+ tf1 = getTransformation o1+ tf2 = getTransformation o2+ in eOffsPP (tf1 ## (x1,y1)) (tf2 ## (x2,y2)) ofs++sameSize :: ObjFn+sameSize [GPI o1, GPI o2] = + let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eSameSize p1 p2++smaller :: ObjFn+smaller [GPI o1, GPI o2] = + let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eSmallerThan p1 p2++-- alignment and ordering: use center of bbox to represent input shapes, and align/order them+-- See more at functions alignPPA and orderPPA ++alignAlong :: ObjFn+alignAlong [GPI o1, GPI o2, Val (FloatV angleInDegrees)] = + let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eAlign p1 p2 angleInDegrees++orderAlong :: ObjFn+orderAlong [GPI o1, GPI o2, Val (FloatV angleInDegrees)] = + let (p1, p2) = (getPolygon o1, getPolygon o2) in+ eOrder p1 p2 angleInDegrees++transformSRT :: ConstCompFn+transformSRT [Val (FloatV sx), Val (FloatV sy), Val (FloatV theta),+ Val (FloatV dx), Val (FloatV dy)] =+ Val $ HMatrixV $ paramsToMatrix (sx, sy, theta, dx, dy)++--------------------------------------------------------------------------------+-- Default functions for every shape++defaultConstrsOf :: ShapeTypeStr -> [FuncName]+defaultConstrsOf "Text" = []+defaultConstrsOf "Curve" = []+-- defaultConstrsOf "Line" = []+defaultConstrsOf _ = [] -- [ "minSize", "maxSize" ]+ -- TODO: remove? these fns make the optimization too hard to solve sometimes+defaultObjFnsOf :: ShapeTypeStr -> [FuncName]+defaultObjFnsOf _ = [] -- NOTE: not used yet++--------------------------------------------------------------------------------+-- Errors+noFunctionError n = error ("Cannot find function \"" ++ n ++ "\"")+noSignatureError n = error ("Cannot find signatures defined for function \"" ++ n ++ "\"")+sigMismatchError n sig argTypes =+ error ("Invalid arguments for function \"" ++ n+ ++ "\". Passed in:\n" ++ show argTypes+ ++ "\nPredefined signature is: " ++ show sig)+noMatchedSigError n sigs argTypes =+ error ("Cannot find matching signatures defined for function \"" ++ n+ ++ "\". Passed in:\n" ++ show argTypes+ ++ "\nPossible signatures are: " ++ sigStrs)+ where sigStrs = concatMap ((++ "\n") . show) sigs++--------------------------------------------------------------------------------+-- DEBUG: main function+--+-- main :: IO ()+-- main = do+-- -- let c = Circle+-- -- let c = Arrow :: ShapeT+-- print $ toJSON (ColorV black :: Value Color)+-- print $ defaultShapeOf circType+-- print $ invokeComp "rgba" [Val (FloatV 1), Val (FloatV 0.0), Val (FloatV 0.0), Val (FloatV 0.0)] compSignatures+-- print $ invokeComp "rgba" [Val (StrV "Wrong arg"), Val (FloatV 0.0), Val (FloatV 0.0), Val (FloatV 0.0)] compSignatures+-- print $ invokeConstr "at" [GPI exampleCirc, Val (IntV 1), Val (FloatV 0.0) ] constrSignatures
+ src/GenOptProblem.hs view
@@ -0,0 +1,1228 @@+{-# LANGUAGE BangPatterns #-}+-- | The GenOptProblem module performs several passes on the translation generated+-- by the Style compiler to generate the initial state (fields and GPIs) and optimization problem+-- (objectives, constraints, and computations) specified by the Substance/Style pair.++{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction #-}+{-# LANGUAGE DeriveGeneric #-}+-- Mostly for autodiff++module GenOptProblem where++import Utils+import Shapes+import Transforms+import qualified SubstanceJSON as J+import qualified Substance as C+import Env+import Style+import Functions+import Text.Show.Pretty (ppShow, pPrint)+import System.Random+import Debug.Trace+import qualified Data.Map.Strict as M+import Control.Monad (foldM, forM_)+import Data.List (foldl', minimumBy, intercalate, partition)+import Data.Array (assocs)+import Data.Either (partitionEithers)+import System.Console.Pretty (Color (..), Style (..), bgColor, color, style, supportsPretty)+import qualified Data.Set as Set+import qualified Data.Graph as Graph+import GHC.Float (float2Double, double2Float)+import qualified Data.Maybe as DM (fromJust)+import qualified Data.Aeson as A+import GHC.Generics+import qualified Numeric.LinearAlgebra as L++-- default (Int, Float)++-------------------- Type definitions++type StyleOptFn = (String, [Expr]) -- Objective or constraint++data OptType = Objfn | Constrfn+ deriving (Show, Eq)++data Fn = Fn { fname :: String,+ fargs :: [Expr],+ optType :: OptType }+ deriving (Show, Eq)++data FnDone a = FnDone { fname_d :: String,+ fargs_d :: [ArgVal a],+ optType_d :: OptType }+ deriving (Show, Eq)++-- A map from the varying path to its value, used to look up values in the translation+type VaryMap a = M.Map Path (TagExpr a)++------- State type definitions++-- Stores the last EP varying state (that is, the state when the unconstrained opt last converged)+type LastEPstate = [Double] -- Note: NOT polymorphic (due to system slowness with polymorphism)++data OptStatus = NewIter+ | UnconstrainedRunning LastEPstate+ | UnconstrainedConverged LastEPstate+ | EPConverged++instance Show OptStatus where+ show NewIter = "New iteration"+ show (UnconstrainedRunning lastEPstate) =+ "Unconstrained running" -- with last EP state:\n" ++ show lastEPstate+ show (UnconstrainedConverged lastEPstate) =+ "Unconstrained converged" -- with last EP state:\n" ++ show lastEPstate+ show EPConverged = "EP converged"++instance Eq OptStatus where+ x == y = case (x, y) of+ (NewIter, NewIter) -> True+ (EPConverged, EPConverged) -> True+ (UnconstrainedRunning a, UnconstrainedRunning b) -> a == b+ (UnconstrainedConverged a, UnconstrainedConverged b) -> a == b+ (_, _) -> False++data Params = Params { weight :: Float,+ optStatus :: OptStatus,+ -- overallObjFn :: forall a . (Autofloat a) => StdGen -> a -> [a] -> a,+ bfgsInfo :: BfgsParams+ }++instance Show Params where+ show p = "Weight: " ++ show (weight p) ++ " | Opt status: " ++ show (optStatus p)+ -- ++ "\nBFGS info:\n" ++ show (bfgsInfo p)++data BfgsParams = BfgsParams {+ lastState :: Maybe [Double], -- x_k+ lastGrad :: Maybe [Double], -- gradient of f(x_k)+ invH :: Maybe [[Double]], -- (BFGS only) estimate of the inverse of the hessian, H_k (TODO: are these indices right?)+ s_list :: [[Double]], -- (L-BFGS only) s_i (state difference) from k-1 to k-m+ y_list :: [[Double]], -- (L-BFGS only) y_i (grad difference) from k-1 to k-m+ numUnconstrSteps :: Int, -- (L-BFGS only) number of steps so far, starting at 0+ memSize :: Int -- (L-BFGS only) number of vectors to retain+} deriving Show++-- data BfgsParams = BfgsParams {+-- lastState :: Maybe (L.Vector L.R), -- x_k+-- lastGrad :: Maybe (L.Vector L.R), -- gradient of f(x_k)+-- invH :: Maybe (L.Matrix L.R), -- (BFGS only) estimate of the inverse of the hessian, H_k (TODO: are these indices right?)+-- s_list :: [L.Vector L.R], -- (L-BFGS only) s_i (state difference) from k-1 to k-m+-- y_list :: [L.Vector L.R], -- (L-BFGS only) y_i (grad difference) from k-1 to k-m+-- numUnconstrSteps :: Int, -- (L-BFGS only) number of steps so far, starting at 0+-- memSize :: Int -- (L-BFGS only) number of vectors to retain+-- }++-- instance Show BfgsParams where+-- show s = "\nBFGS params:\n" +++-- "\nlastState: \n" ++ ppShow (lastState s) +++-- "\nlastGrad: \n" ++ ppShow (lastGrad s) +++-- "\ninvH: \n" ++ ppShow (invH s) +++-- -- This is a lot of output (can be 2 * defaultBfgsMemSize * state size)+-- -- "\ns_list:\n" ++ ppShow (s_list s) +++-- -- "\ny_list:\n" ++ ppShow (y_list s) +++-- "\nlength of s_list:\n" ++ (show $ length $ s_list s) +++-- "\nlength of y_list:\n" ++ (show $ length $ y_list s) +++-- "\nnumUnconstrSteps:\n" ++ ppShow (numUnconstrSteps s) +++-- "\nmemSize:\n" ++ ppShow (memSize s) ++ "\n\n"++defaultBfgsMemSize :: Int+defaultBfgsMemSize = 17+-- Shorter memory seems to work better in practice; Nocedal says between 3 and 30 is a good `m` (see p227)+-- but the choice of `m` is also problem-dependent++defaultBfgsParams = BfgsParams { lastState = Nothing, lastGrad = Nothing, invH = Nothing,+ s_list = [], y_list = [], numUnconstrSteps = 0, memSize = defaultBfgsMemSize }++type PolicyState = String -- Should this include the functions that it returned last time?+type Policy = [Fn] -> [Fn] -> PolicyParams -> (Maybe [Fn], PolicyState)++data PolicyParams = PolicyParams { policyState :: String,+ policySteps :: Int,+ currFns :: [Fn]+ }++instance Show PolicyParams where+ show p = "Policy state: " ++ policyState p ++ " | Policy steps: " ++ show (policySteps p)+ -- ++ "\nFunctions:\n" ++ ppShow (currFns p)++data OptMethod = Newton | BFGS | LBFGS | GradientDescent+ deriving (Eq, Show, Generic)++instance A.ToJSON OptMethod where+ toEncoding = A.genericToEncoding A.defaultOptions++instance A.FromJSON OptMethod++data OptConfig = OptConfig {+ optMethod :: OptMethod+ } deriving (Eq, Show, Generic)++defaultOptConfig = OptConfig { optMethod = LBFGS }++instance A.ToJSON OptConfig where+ toEncoding = A.genericToEncoding A.defaultOptions++instance A.FromJSON OptConfig++data State = State { shapesr :: [Shape Double],+ shapeNames :: [(String, Field)], -- TODO Sub name type+ shapeOrdering :: [String],+ shapeProperties :: [(String, Field, Property)],+ transr :: Translation Double,+ varyingPaths :: [Path],+ uninitializedPaths :: [Path],+ pendingPaths :: [Path],+ varyingState :: [Double], -- Note: NOT polymorphic+ paramsr :: Params,+ objFns :: [Fn],+ constrFns :: [Fn],+ rng :: StdGen,+ autostep :: Bool, -- TODO: deprecate this+ -- policyFn :: Policy,+ policyParams :: PolicyParams,+ oConfig :: OptConfig }++instance Show State where+ show s = "Shapes: \n" ++ ppShow (shapesr s) +++ "\nShape names: \n" ++ ppShow (shapeNames s) +++ "\nTranslation: \n" ++ ppShow (transr s) +++ "\nVarying paths: \n" ++ ppShow (varyingPaths s) +++ "\nUninitialized paths: \n" ++ ppShow (uninitializedPaths s) +++ "\nVarying state: \n" ++ ppShow (varyingState s) +++ "\nParams: \n" ++ ppShow (paramsr s) +++ "\nObjective Functions: \n" ++ ppShowList (objFns s) +++ "\nConstraint Functions: \n" ++ ppShowList (constrFns s) +++ "\nAutostep: \n" ++ ppShow (autostep s)++-- Reimplementation of 'ppShowList' from pretty-show. Not sure why it cannot be imported at all+ppShowList = concatMap ((++) "\n" . ppShow)++--------------- Constants++-- For evaluating expressions+startingIteration, maxEvalIteration :: Int+startingIteration = 0+maxEvalIteration = 500 -- Max iteration depth in case of cycles++evalIterRange :: (Int, Int)+evalIterRange = (startingIteration, maxEvalIteration)++initRng :: StdGen+initRng = mkStdGen seed+ where seed = 17 -- deterministic RNG with seed++--------------- Parameters used in optimization+-- Should really be in Optimizer, but need to fix module import structure++constrWeight :: Floating a => a+constrWeight = 10 ^ 4++-- for use in barrier/penalty method (interior/exterior point method)+-- seems if the point starts in interior + weight starts v small and increases, then it converges+-- not quite: if the weight is too small then the constraint will be violated+initWeight :: Autofloat a => a+-- initWeight = 10 ** (-5)++-- Converges very fast w/ constraints removed (function-composition.sub)+-- initWeight = 0++-- Steps very slowly with a higher weight; does not seem to converge but looks visually OK (function-composition.sub)+-- initWeight = 1+initWeight = 10 ** (-3)++policyToUse :: Policy+policyToUse = optimizeSumAll+-- policyToUse = optimizeConstraintsThenObjectives+-- policyToUse = optimizeConstraints+-- policyToUse = optimizeObjectives++--------------- Utility functions++declaredVarying :: (Autofloat a) => TagExpr a -> Bool+declaredVarying (OptEval (AFloat Vary)) = True+declaredVarying _ = False++sumMap :: Floating b => (a -> b) -> [a] -> b -- common pattern in objective functions+sumMap f l = sum $ map f l++-- TODO: figure out what to do with sty vars+mkPath :: [String] -> Path+mkPath [name, field] = FieldPath (BSubVar (VarConst name)) field+mkPath [name, field, property] = PropertyPath (BSubVar (VarConst name)) field property++pathToList :: Path -> [String]+pathToList (FieldPath (BSubVar (VarConst name)) field) = [name, field]+pathToList (PropertyPath (BSubVar (VarConst name)) field property) = [name, field, property]+pathToList _ = error "pathToList should not handle Sty vars"++isFieldPath :: Path -> Bool+isFieldPath (FieldPath _ _) = True+isFieldPath (PropertyPath _ _ _) = False++bvarToString :: BindingForm -> String+bvarToString (BSubVar (VarConst s)) = s+bvarToString (BStyVar (StyVar' s)) = s -- For namespaces+ -- error ("bvarToString: cannot handle Style variable: " ++ show v)++getShapeName :: String -> Field -> String+getShapeName subName field = subName ++ "." ++ field++-- For varying values to be inserted into varyMap+floatToTagExpr :: (Autofloat a) => a -> TagExpr a+floatToTagExpr n = Done (FloatV n)++-- | converting from Value to TagExpr+toTagExpr :: (Autofloat a) => Value a -> TagExpr a+toTagExpr v = Done v++-- | converting from TagExpr to Value+toVal :: (Autofloat a) => TagExpr a -> Value a+toVal (Done v) = v+toVal (OptEval _) = error "Shape properties were not fully evaluated"++toFn :: OptType -> StyleOptFn -> Fn+toFn otype (name, args) = Fn { fname = name, fargs = args, optType = otype }++toFns :: ([StyleOptFn], [StyleOptFn]) -> ([Fn], [Fn])+toFns (objfns, constrfns) = (map (toFn Objfn) objfns, map (toFn Constrfn) constrfns)++list2 (a, b) = [a, b]++mkVaryMap :: (Autofloat a) => [Path] -> [a] -> VaryMap a+mkVaryMap varyPaths varyVals = M.fromList $ zip varyPaths (map floatToTagExpr varyVals)++------------------- Translation helper functions++------ Generic functions for folding over a translation++foldFields :: (Autofloat a) => (String -> Field -> FieldExpr a -> [b] -> [b]) ->+ Name -> FieldDict a -> [b] -> [b]+foldFields f name fieldDict acc =+ let name' = nameStr name in -- TODO do we need do anything with Sub vs Gen names?+ let res = M.foldrWithKey (f name') [] fieldDict in+ res ++ acc++foldSubObjs :: (Autofloat a) => (String -> Field -> FieldExpr a -> [b] -> [b]) -> Translation a -> [b]+foldSubObjs f trans = M.foldrWithKey (foldFields f) [] (trMap trans)++------- Inserting into a translation++insertGPI :: (Autofloat a) =>+ Translation a -> String -> Field -> ShapeTypeStr -> PropertyDict a+ -> Translation a+insertGPI trans n field t propDict = case M.lookup (Sub n) $ trMap trans of+ Nothing -> error "Substance ID does not exist"+ Just fieldDict ->+ let fieldDict' = M.insert field (FGPI t propDict) fieldDict+ trMap' = M.insert (Sub n) fieldDict' $ trMap trans+ in trans { trMap = trMap' }++insertPath :: (Autofloat a) => Translation a -> (Path, TagExpr a) -> Either [Error] (Translation a)+insertPath trans (path, expr) =+ let overrideFlag = False in -- These paths should not exist in trans+ addPath overrideFlag trans path expr++insertPaths :: (Autofloat a) => [Path] -> [TagExpr a] -> Translation a -> Translation a+insertPaths varyingPaths varying trans =+ if length varying /= length varyingPaths+ then error "not the same # varying paths as varying variables"+ else case foldM insertPath trans (zip varyingPaths varying) of+ Left errs -> error $ "Error while adding varying paths: " ++ intercalate "\n" errs+ Right tr -> tr++------- Looking up fields/properties in a translation++-- First check if the path is a varying path. If so then use the varying value+-- (The value in the translation is stale and should be ignored)+-- If not then use the expr in the translation+lookupFieldWithVarying :: (Autofloat a) => BindingForm -> Field -> Translation a -> VaryMap a -> FieldExpr a+lookupFieldWithVarying bvar field trans varyMap =+ case M.lookup (mkPath [bvarToString bvar, field]) varyMap of+ Just varyVal -> {-trace "field lookup was vary" $ -} FExpr varyVal+ Nothing -> {-trace "field lookup was not vary" $ -} lookupField bvar field trans++lookupPropertyWithVarying :: (Autofloat a) => BindingForm -> Field -> Property+ -> Translation a -> VaryMap a -> TagExpr a+lookupPropertyWithVarying bvar field property trans varyMap =+ case M.lookup (mkPath [bvarToString bvar, field, property]) varyMap of+ Just varyVal -> {-trace "property lookup was vary" $ -} varyVal+ Nothing -> {- trace "property lookup was not vary" $ -} lookupProperty bvar field property trans++lookupProperty :: (Autofloat a) => BindingForm -> Field -> Property -> Translation a -> TagExpr a+lookupProperty bvar field property trans =+ let name = trName bvar in+ case lookupField bvar field trans of+ FExpr e ->+ -- to deal with path synonyms, e.g. `y.f = some GPI with property p; z.f = y.f; z.f.p = some value`+ -- if we're looking for `z.f.p` and we find out that `z.f = y.f`, then look for `y.f.p` instead+ -- NOTE: this makes a recursive call!+ case e of+ OptEval (EPath (FieldPath bvarSynonym fieldSynonym)) ->+ if bvar == bvarSynonym && field == fieldSynonym+ then error ("nontermination in lookupProperty with path '" ++ pathStr3 name field property ++ "' set to itself")+ else lookupProperty bvarSynonym fieldSynonym property trans+ -- the only thing that might have properties is another field path+ _ -> error ("path '" ++ pathStr3 name field property ++ "' has no properties")+ FGPI ctor properties ->+ case M.lookup property properties of+ Nothing -> error ("path '" ++ pathStr3 name field property ++ "'s property does not exist")+ Just texpr -> texpr++lookupPaths :: (Autofloat a) => [Path] -> Translation a -> [a]+lookupPaths paths trans = map lookupPath paths+ where+ lookupPath p@(FieldPath v field) = case lookupField v field trans of+ FExpr (OptEval (AFloat (Fix n))) -> r2f n+ FExpr (Done (FloatV n)) -> r2f n+ xs -> error ("varying path \"" ++ pathStr p ++ "\" is invalid: is '" ++ show xs ++ "'")+ lookupPath p@(PropertyPath v field pty) = case lookupProperty v field pty trans of+ OptEval (AFloat (Fix n)) -> r2f n+ Done (FloatV n) -> n+ xs -> error ("varying path \"" ++ pathStr p ++ "\" is invalid: is '" ++ show xs ++ "'")++-- TODO: resolve label logic here?+shapeExprsToVals :: (Autofloat a) => (String, Field) -> PropertyDict a -> Properties a+shapeExprsToVals (subName, field) properties =+ let shapeName = getShapeName subName field+ properties' = M.map toVal properties+ in M.insert "name" (StrV shapeName) properties'++getShapes :: (Autofloat a) => [(String, Field)] -> Translation a -> [Shape a]+getShapes shapenames trans = map (getShape trans) shapenames+ -- TODO: fix use of Sub/Sty name here+ where getShape trans (name, field) =+ let fexpr = lookupField (BSubVar $ VarConst name) field trans in+ case fexpr of+ FExpr _ -> error "expected GPI, got field"+ FGPI ctor properties -> (ctor, shapeExprsToVals (name, field) properties)++----- GPI helper functions++shapes2vals :: (Autofloat a) => [Shape a] -> [Path] -> [Value a]+shapes2vals shapes paths = reverse $ foldl' (lookupPath shapes) [] paths+ where+ lookupPath shapes acc (PropertyPath s field property) =+ let subID = bvarToString s+ shapeName = getShapeName subID field in+ get (findShape shapeName shapes) property : acc+ lookupPath _ acc (FieldPath _ _) = acc++-- Given a set of new shapes (from the frontend) and a varyMap (for varying field values):+-- look up property values in the shapes and field values in the varyMap+-- NOTE: varyState is constructed using a foldl, so to preserve its order, we must reverse the list of values!+shapes2floats :: (Autofloat a) => [Shape a] -> VaryMap a -> [Path] -> [a]+shapes2floats shapes varyMap varyingPaths = reverse $ foldl' (lookupPathFloat shapes varyMap) [] varyingPaths+ where+ lookupPathFloat :: (Autofloat a) => [Shape a] -> VaryMap a -> [a] -> Path -> [a]+ lookupPathFloat shapes _ acc (PropertyPath s field property) =+ let subID = bvarToString s+ shapeName = getShapeName subID field in+ getNum (findShape shapeName shapes) property : acc+ lookupPathFloat _ varyMap acc fp@(FieldPath _ _) =+ case M.lookup fp varyMap of+ Just (Done (FloatV num)) -> num : acc+ Just _ -> error ("wrong type for varying field path (expected float): " ++ show fp)+ Nothing -> error ("could not find varying field path '" ++ show fp ++ "' in varyMap")++--------------------------------- Analyzing the translation++--- Find varying (float) paths++-- For now, don't optimize these float-valued properties of a GPI +-- (use whatever they are initialized to in Shapes or set to in Style)+unoptimizedFloatProperties :: [String]+unoptimizedFloatProperties = ["rotation", "strokeWidth", "thickness", + "transform", "transformation"]++-- If any float property is not initialized in properties,+-- or it's in properties and declared varying, it's varying+findPropertyVarying :: (Autofloat a) => String -> Field -> M.Map String (TagExpr a) ->+ String -> [Path] -> [Path]+findPropertyVarying name field properties floatProperty acc =+ case M.lookup floatProperty properties of+ Nothing -> if floatProperty `elem` unoptimizedFloatProperties then acc + else mkPath [name, field, floatProperty] : acc+ Just expr -> if declaredVarying expr then mkPath [name, field, floatProperty] : acc+ else acc++findFieldVarying :: (Autofloat a) => String -> Field -> FieldExpr a -> [Path] -> [Path]+findFieldVarying name field (FExpr expr) acc =+ if declaredVarying expr+ then mkPath [name, field] : acc -- TODO: deal with StyVars+ else acc+findFieldVarying name field (FGPI typ properties) acc =+ let ctorFloats = propertiesOf FloatT typ+ varyingFloats = filter (not . isPending typ) ctorFloats+ vs = foldr (findPropertyVarying name field properties) [] varyingFloats+ in vs ++ acc++findVarying :: (Autofloat a) => Translation a -> [Path]+findVarying = foldSubObjs findFieldVarying++--- Find pending paths++-- | Find the paths to all pending, non-float, non-name properties+findPending :: (Autofloat a) => Translation a -> [Path]+findPending = foldSubObjs findFieldPending+ where + findFieldPending name field (FExpr expr) acc = acc+ findFieldPending name field (FGPI typ properties) acc = + let pendingProps = pendingProperties typ+ in map (\p -> mkPath [name, field, p]) pendingProps ++ acc++--- Find uninitialized (non-float) paths++findPropertyUninitialized :: (Autofloat a) => String -> Field -> M.Map String (TagExpr a) ->+ String -> [Path] -> [Path]+findPropertyUninitialized name field properties nonfloatProperty acc =+ case M.lookup nonfloatProperty properties of+ -- nonfloatProperty is a non-float property that is NOT set by the user and thus we can sample it+ Nothing -> mkPath [name, field, nonfloatProperty] : acc+ Just expr -> acc++findFieldUninitialized :: (Autofloat a) => String -> Field -> FieldExpr a -> [Path] -> [Path]+-- NOTE: we don't find uninitialized field because you can't leave them uninitialized. Plus, we don't know what types they are+findFieldUninitialized name field (FExpr expr) acc = acc+findFieldUninitialized name field (FGPI typ properties) acc =+ let ctorNonfloats = filter (/= "name") $ propertiesNotOf FloatT typ in+ -- TODO: add a separate field (e.g. pendingPaths) in State to store these special properties that needs frontend updates+ let uninitializedProps = ctorNonfloats in+ let vs = foldr (findPropertyUninitialized name field properties) [] uninitializedProps in+ vs ++ acc++-- | Find the paths to all uninitialized, non-float, non-name properties+findUninitialized :: (Autofloat a) => Translation a -> [Path]+findUninitialized = foldSubObjs findFieldUninitialized++--- Find various kinds of functions++findObjfnsConstrs :: (Autofloat a) => Translation a -> [Either StyleOptFn StyleOptFn]+findObjfnsConstrs = foldSubObjs findFieldFns+ where findFieldFns :: (Autofloat a) => String -> Field -> FieldExpr a -> [Either StyleOptFn StyleOptFn]+ -> [Either StyleOptFn StyleOptFn]+ findFieldFns name field (FExpr (OptEval expr)) acc =+ case expr of+ ObjFn fname args -> Left (fname, args) : acc+ ConstrFn fname args -> Right (fname, args) : acc+ _ -> acc -- Not an optfn+ -- COMBAK: what should we do if there's a constant field?+ findFieldFns name field (FExpr (Done _)) acc = acc+ findFieldFns name field (FGPI _ _) acc = acc++findDefaultFns :: (Autofloat a) => Translation a -> [Either StyleOptFn StyleOptFn]+findDefaultFns = foldSubObjs findFieldDefaultFns+ where findFieldDefaultFns :: (Autofloat a) => String -> Field -> FieldExpr a ->+ [Either StyleOptFn StyleOptFn] -> [Either StyleOptFn StyleOptFn]+ findFieldDefaultFns name field gpi@(FGPI typ props) acc =+ let args = [EPath $ FieldPath (BSubVar (VarConst name)) field]+ objs = map (Left . addArgs args) $ defaultObjFnsOf typ+ constrs = map (Right . addArgs args) $ defaultConstrsOf typ+ in constrs ++ objs ++ acc+ where addArgs arguments f = (f, arguments)+ findFieldDefaultFns _ _ _ acc = acc++--- Find shapes and their properties++findShapeNames :: (Autofloat a) => Translation a -> [(String, Field)]+findShapeNames = foldSubObjs findGPIName+ where findGPIName :: (Autofloat a) => String -> Field -> FieldExpr a ->+ [(String, Field)] -> [(String, Field)]+ findGPIName name field (FGPI _ _) acc = (name, field) : acc+ findGPIName _ _ (FExpr _) acc = acc++findShapesProperties :: (Autofloat a) => Translation a -> [(String, Field, Property)]+findShapesProperties = foldSubObjs findShapeProperties+ where findShapeProperties :: (Autofloat a) => String -> Field -> FieldExpr a -> [(String, Field, Property)]+ -> [(String, Field, Property)]+ findShapeProperties name field (FGPI ctor properties) acc =+ let paths = map (\property -> (name, field, property)) (M.keys properties)+ in paths ++ acc+ findShapeProperties _ _ (FExpr _) acc = acc++------------------------------ Evaluating the translation and expressions/GPIs in it++-- TODO: write a more general typechecking mechanism+evalUop :: (Autofloat a) => UnaryOp -> ArgVal a -> Value a+evalUop UMinus v = case v of+ Val (FloatV a) -> FloatV (-a)+ Val (IntV i) -> IntV (-i)+ GPI _ -> error "cannot negate a GPI"+ Val _ -> error "wrong type to negate"+evalUop UPlus v = error "unary + doesn't make sense" -- TODO remove from parser++evalBinop :: (Autofloat a) => BinaryOp -> ArgVal a -> ArgVal a -> Value a+evalBinop op v1 v2 =+ case (v1, v2) of+ (Val (FloatV n1), Val (FloatV n2)) ->+ case op of+ BPlus -> FloatV $ n1 + n2+ BMinus -> FloatV $ n1 - n2+ Multiply -> FloatV $ n1 * n2+ Divide -> if n2 == 0 then error "divide by 0!" else FloatV $ n1 / n2+ Exp -> FloatV $ n1 ** n2+ (Val (IntV n1), Val (IntV n2)) ->+ case op of+ BPlus -> IntV $ n1 + n2+ BMinus -> IntV $ n1 - n2+ Multiply -> IntV $ n1 * n2+ Divide -> if n2 == 0 then error "divide by 0!" else IntV $ n1 `quot` n2 -- NOTE: not float+ Exp -> IntV $ n1 ^ n2+ -- Cannot mix int and float+ (Val _, Val _) -> error ("wrong field types for binary op: " ++ show v1 ++ show op ++ show v2)+ (GPI _, Val _) -> error "binop cannot operate on GPI"+ (Val _, GPI _) -> error "binop cannot operate on GPI"+ (GPI _, GPI _) -> error "binop cannot operate on GPIs"++-- | Given a path that is a computed property of a shape (e.g. A.shape.transformation), evaluate each of its arguments (e.g. A.shape.sizeX), pass the results to the property-computing function, and return the result (e.g. an HMatrix)+computeProperty :: (Autofloat a) => (Int, Int) -> BindingForm -> Field -> Property -> VaryMap a -> Translation a -> StdGen -> ComputedValue a -> (ArgVal a, Translation a, StdGen)+computeProperty limit bvar field property varyMap trans g (props, compFn) =+ let args = map (\p -> EPath $ PropertyPath bvar field p) props+ (argVals, trans', g') = evalExprs limit args trans varyMap g+ propertyValue = compFn $ map fromGPI argVals in+ (Val propertyValue, trans', g')+ where fromGPI (Val x) = x+ fromGPI (GPI x) = error "expected value as prop fn arg, got GPI"++evalProperty :: (Autofloat a)+ => (Int, Int) -> BindingForm -> Field -> VaryMap a -> ([(Property, TagExpr a)], Translation a, StdGen) -> (Property, TagExpr a)+ -> ([(Property, TagExpr a)], Translation a, StdGen)+evalProperty (i, n) bvar field varyMap (propertiesList, trans, g) (property, expr) =+ let path = EPath $ PropertyPath bvar field property in -- factor out?+ let (res, trans', g') = evalExpr (i, n) path trans varyMap g in+ -- This check might be redundant with the later GPI conversion in evalExpr, TODO factor out+ case res of+ Val val -> ((property, Done val) : propertiesList, trans', g')+ GPI _ -> error "GPI property should not evaluate to GPI argument" -- TODO: true later? references?++evalGPI_withUpdate :: (Autofloat a)+ => (Int, Int) -> BindingForm -> Field -> (GPICtor, PropertyDict a) -> Translation a -> VaryMap a -> StdGen+ -> ((GPICtor, PropertyDict a), Translation a, StdGen)+evalGPI_withUpdate (i, n) bvar field (ctor, properties) trans varyMap g =+ -- Fold over the properties, evaluating each path, which will update the translation each time,+ -- and accumulate the new property-value list (WITH varying looked up)+ let (propertyList', trans', g') = foldl' (evalProperty (i, n) bvar field varyMap) ([], trans, g) (M.toList properties) in+ let properties' = M.fromList propertyList' in+ {-trace ("Start eval GPI: " ++ show properties ++ " " ++ "\n\tctor: " ++ "\n\tfield: " ++ show field)-}+ ((ctor, properties'), trans', g')++-- recursively evaluate, tracking iteration depth in case there are cycles in graph+evalExpr :: (Autofloat a) => (Int, Int) -> Expr -> Translation a -> VaryMap a -> StdGen -> (ArgVal a, Translation a, StdGen)+evalExpr (i, n) arg trans varyMap g =+ if i >= n then error ("evalExpr: iteration depth exceeded (" ++ show n ++ ")")+ else {-trace ("Evaluating expression: " ++ show arg ++ "\n(i, n): " ++ show i ++ ", " ++ show n)-} argResult+ where limit = (i + 1, n)+ argResult = case arg of+ -- Already done values; don't change trans+ IntLit i -> (Val $ IntV i, trans, g)+ StringLit s -> (Val $ StrV s, trans, g)+ BoolLit b -> (Val $ BoolV b, trans, g)+ AFloat (Fix f) -> (Val $ FloatV (r2f f), trans, g) -- TODO: note use of r2f here. is that ok?+ AFloat Vary -> error "evalExpr should not encounter an uninitialized varying float!"++ -- Inline computation, needs a recursive lookup that may change trans, but not a path+ -- TODO factor out eval / trans computation?+ UOp op e ->+ let (val, trans', g') = evalExpr limit e trans varyMap g in+ let compVal = evalUop op val in+ (Val compVal, trans', g')+ BinOp op e1 e2 ->+ let ([v1, v2], trans', g') = evalExprs limit [e1, e2] trans varyMap g in+ let compVal = evalBinop op v1 v2 in+ (Val compVal, trans', g')+ CompApp fname args ->+ -- NOTE: the goal of all the rng passing in this module is for invoking computations with randomization+ let (vs, trans', g') = evalExprs limit args trans varyMap g+ (compRes, g'') = invokeComp fname vs compSignatures g'+ in (compRes, trans', g'')+ -- -- TODO: invokeComp should be used here+ -- case M.lookup fname compDict of+ -- Nothing -> error ("computation '" ++ fname ++ "' doesn't exist")+ -- Just f -> let res = f vs in+ -- (res, trans')+ List es ->+ let (vs, trans', g') = evalExprs limit es trans varyMap g+ floatvs = map checkFloatType vs+ in (Val $ ListV floatvs, trans', g')++ ListAccess p i -> error "TODO list accesses"++ Tuple e1 e2 ->+ let (vs, trans', g') = evalExprs limit [e1, e2] trans varyMap g+ [v1, v2] = map checkFloatType vs+ in (Val $ TupV (v1, v2), trans', g')++ -- Needs a recursive lookup that may change trans. The path case is where trans is actually changed.+ EPath p ->+ case p of+ FieldPath bvar field ->+ -- Lookup field expr, evaluate it if necessary, cache the evaluated value in the trans,+ -- return the evaluated value and the updated trans+ let fexpr = lookupFieldWithVarying bvar field trans varyMap in+ case fexpr of+ FExpr (Done v) -> (Val v, trans, g)+ FExpr (OptEval e) ->+ let (v, trans', g') = evalExpr limit e trans varyMap g in+ case v of+ Val fval ->+ case insertPath trans' (p, Done fval) of+ Right trans' -> (v, trans', g')+ Left err -> error $ concat err+ gpiVal@(GPI _) -> (gpiVal, trans', g') -- to deal with path synonyms, e.g. "y.f = some GPI; z.f = y.f"+ FGPI ctor properties ->+ -- Eval each property in the GPI, storing each property result in a new dictionary+ -- No need to update the translation because each path should update the translation+ let (gpiVal@(ctor', propertiesVal), trans', g') =+ evalGPI_withUpdate limit bvar field (ctor, properties) trans varyMap g in+ (GPI (ctor', shapeExprsToVals (bvarToString bvar, field) propertiesVal), trans', g')++ PropertyPath bvar field property ->+ let gpiType = shapeType bvar field trans in+ -- case M.lookup (gpiType, property) computedProperties of + -- Just computeValueInfo -> computeProperty limit bvar field property varyMap trans g computeValueInfo+ -- Nothing -> -- Compute the path as usual+ let texpr = lookupPropertyWithVarying bvar field property trans varyMap in+ case texpr of+ Pending v -> (Val v, trans, g)+ Done v -> (Val v, trans, g)+ OptEval e ->+ let (v, trans', g') = evalExpr limit e trans varyMap g in+ case v of+ Val fval ->+ case insertPath trans' (p, Done fval) of+ Right trans' -> (v, trans', g')+ Left err -> error $ concat err+ GPI _ -> error ("path to property expr '" ++ pathStr p ++ "' evaluated to a GPI")++ -- GPI argument+ Ctor ctor properties -> error "no anonymous/inline GPIs allowed as expressions!"++ -- Error+ Layering _ _ -> error "layering should not be an objfn arg (or in the children of one)"+ ObjFn _ _ -> error "objfn should not be an objfn arg (or in the children of one)"+ ConstrFn _ _ -> error "constrfn should not be an objfn arg (or in the children of one)"+ AvoidFn _ _ -> error "avoidfn should not be an objfn arg (or in the children of one)"+ PluginAccess _ _ _ -> error "plugin access should not be evaluated at runtime"+ -- xs -> error ("unmatched case in evalExpr with argument: " ++ show xs)++checkFloatType :: (Autofloat a) => ArgVal a -> a+checkFloatType (Val (FloatV x)) = x+checkFloatType _ = error "expected float type"++-- Any evaluated exprs are cached in the translation for future evaluation+-- The varyMap is not changed because its values are final (set by the optimization)+evalExprs :: (Autofloat a)+ => (Int, Int) -> [Expr] -> Translation a -> VaryMap a -> StdGen+ -> ([ArgVal a], Translation a, StdGen)+evalExprs limit args trans varyMap g =+ foldl' (evalExprF limit varyMap) ([], trans, g) args+ where evalExprF :: (Autofloat a) => (Int, Int) -> VaryMap a -> ([ArgVal a], Translation a, StdGen) -> Expr -> ([ArgVal a], Translation a, StdGen)+ evalExprF limit varyMap (argvals, trans, rng) arg =+ let (argVal, trans', rng') = evalExpr limit arg trans varyMap rng in+ (argvals ++ [argVal], trans', rng') -- So returned exprs are in same order++------------------- Generating and evaluating the objective function++evalFnArgs :: (Autofloat a) => (Int, Int) -> VaryMap a -> ([FnDone a], Translation a, StdGen) -> Fn -> ([FnDone a], Translation a, StdGen)+evalFnArgs limit varyMap (fnDones, trans, g) fn =+ let args = fargs fn in+ let (argsVal, trans', g') = evalExprs limit (fargs fn) trans varyMap g in+ let fn' = FnDone { fname_d = fname fn, fargs_d = argsVal, optType_d = optType fn } in+ (fnDones ++ [fn'], trans', g') -- TODO factor out this pattern++evalFns :: (Autofloat a)+ => (Int, Int) -> [Fn] -> Translation a -> VaryMap a -> StdGen+ -> ([FnDone a], Translation a, StdGen)+evalFns limit fns trans varyMap g = foldl' (evalFnArgs limit varyMap) ([], trans, g) fns++applyOptFn :: (Autofloat a) =>+ M.Map String (OptFn a) -> OptSignatures -> FnDone a -> a+applyOptFn dict sigs finfo =+ let (name, args) = (fname_d finfo, fargs_d finfo)+ in invokeOptFn dict name args sigs++applyCombined :: (Autofloat a) => a -> [FnDone a] -> a+applyCombined penaltyWeight fns =+ -- TODO: pass the functions in separately? The combining + separating seem redundant+ let (objfns, constrfns) = partition (\f -> optType_d f == Objfn) fns in+ sumMap (applyOptFn objFuncDict objSignatures) objfns+ + constrWeight * penaltyWeight * sumMap (applyOptFn constrFuncDict constrSignatures) constrfns++-- Main function: generates the objective function, partially applying it with some info++genObjfn :: (Autofloat a)+ => Translation a -> [Fn] -> [Fn] -> [Path]+ -> StdGen -> a -> [a]+ -> a+genObjfn trans objfns constrfns varyingPaths =+ \rng penaltyWeight varyingVals ->+ let varyMap = tr "varyingMap: " $ mkVaryMap varyingPaths varyingVals in+ let (fnsE, transE, rng') = evalFns evalIterRange (objfns ++ constrfns) trans varyMap rng in+ applyCombined penaltyWeight fnsE++evalEnergyOn :: (Autofloat a) => State -> [a] -> a +evalEnergyOn s vstate = + let varyMap = mkVaryMap (varyingPaths s) vstate+ fns = objFns s ++ constrFns s+ (fnsE, transE, rng') = evalFns evalIterRange fns (castTranslation $ transr s) varyMap (rng s)+ penaltyWeight = r2f $ weight $ paramsr s+ in applyCombined penaltyWeight fnsE++evalEnergy :: (Autofloat a) => State -> a +evalEnergy s = + let varyMap = mkVaryMap (varyingPaths s) (map r2f $ varyingState s) + fns = objFns s ++ constrFns s+ (fnsE, transE, rng') = evalFns evalIterRange fns (castTranslation $ transr s) varyMap (rng s)+ penaltyWeight = r2f $ weight $ paramsr s+ in applyCombined penaltyWeight fnsE++--------------- Generating an initial state (concrete values for all fields/properties needed to draw the GPIs)+-- 1. Initialize all varying fields+-- 2. Initialize all properties of all GPIs++-- NOTE: since we store all varying paths separately, it is okay to mark the default values as Done -- they will still be optimized, if needed.+-- TODO: document the logic here (e.g. only sampling varying floats) and think about whether to use translation here or [Shape a] since we will expose the sampler to users later+initProperty ::+ (Autofloat a)+ => ShapeTypeStr+ -> (PropertyDict a, StdGen)+ -> String+ -> (ValueType, SampledValue a)+ -> (PropertyDict a, StdGen)+initProperty shapeType (properties, g) pID (typ, sampleF) =+ let (v, g') = sampleF g+ autoRndVal = Done v+ in case M.lookup pID properties of+ Just (OptEval (AFloat Vary)) -> (M.insert pID autoRndVal properties, g')+ Just (OptEval e) -> (properties, g)+ Just (Done v) -> (properties, g)+ -- TODO: pending properties are only marked if the Style source does not set them explicitly+ -- Check if this is the right decision. We still give pending values a default such that the initial list of shapes can be generated without errors.+ Nothing -> + if isPending shapeType pID+ then (M.insert pID (Pending v) properties, g')+ else (M.insert pID autoRndVal properties, g')+++initShape :: (Autofloat a) => (Translation a, StdGen) -> (String, Field) -> (Translation a, StdGen)+initShape (trans, g) (n, field) =+ case lookupField (BSubVar (VarConst n)) field trans of+ FGPI shapeType propDict ->+ let def = findDef shapeType+ (propDict', g') = foldlPropertyMappings (initProperty shapeType) (propDict, g) def+ -- NOTE: getShapes resolves the names + we don't use the names of the shapes in the translation+ -- The name-adding logic can be removed but is left in for debugging+ shapeName = getShapeName n field+ propDict'' = M.insert "name" (Done $ StrV shapeName) propDict'+ in (insertGPI trans n field shapeType propDict'', g')+ _ -> error "expected GPI but got field"++initShapes :: (Autofloat a) =>+ Translation a -> [(String, Field)] -> StdGen -> (Translation a, StdGen)+initShapes trans shapePaths gen = foldl' initShape (trans, gen) shapePaths++resampleFields :: (Autofloat a) => [Path] -> StdGen -> ([a], StdGen)+resampleFields varyingPaths g =+ let varyingFields = filter isFieldPath varyingPaths in+ Functions.randomsIn g (fromIntegral $ length varyingFields) Shapes.canvasDims++-- sample varying fields only (from the range defined by canvas dims) and store them in the translation+-- example: A.val = OPTIMIZED+initFields :: (Autofloat a) => [Path] -> Translation a -> StdGen -> (Translation a, StdGen)+initFields varyingPaths trans g =+ let varyingFields = filter isFieldPath varyingPaths+ (sampledVals, g') = Functions.randomsIn g (fromIntegral $ length varyingFields) Shapes.canvasDims+ trans' = insertPaths varyingFields (map (Done . FloatV) sampledVals) trans in+ (trans', g')++------------- Evaluating all shapes in a translation++evalShape :: (Autofloat a) =>+ (Int, Int) -> VaryMap a+ -> ([Shape a], Translation a, StdGen) -> Path+ -> ([Shape a], Translation a, StdGen)+evalShape limit varyMap (shapes, trans, g) shapePath =+ let (res, trans', g') = evalExpr limit (EPath shapePath) trans varyMap g in+ case res of+ GPI shape -> (shape : shapes, trans', g')+ _ -> error "evaluating a GPI path did not result in a GPI"++-- recursively evaluate every shape property in the translation+evalShapes :: (Autofloat a) => (Int, Int) -> [Path] -> Translation a -> VaryMap a -> StdGen -> ([Shape a], Translation a, StdGen)+evalShapes limit shapeNames trans varyMap rng =+ let (shapes, trans', rng') = foldl' (evalShape limit varyMap) ([], trans, rng) shapeNames in+ (reverse shapes, trans', rng')++-- Given the shape names, use the translation and the varying paths/values in order to evaluate each shape+-- with respect to the varying values+evalTranslation :: State -> ([Shape Double], Translation Double, StdGen)+evalTranslation s =+ let varyMap = mkVaryMap (varyingPaths s) (map r2f $ varyingState s) in+ evalShapes evalIterRange (map (mkPath . list2) $ shapeNames s) (transr s) varyMap (rng s)++------------- Compute global layering of GPIs++lookupGPIName :: (Autofloat a) => Path -> Translation a -> String+lookupGPIName path@(FieldPath v field) trans =+ case lookupField v field trans of+ FExpr e -> + -- to deal with path synonyms in a layering statement (see `lookupProperty` for more explanation)+ case e of+ OptEval (EPath pathSynonym@(FieldPath vSynonym fieldSynonym)) ->+ if v == vSynonym && field == fieldSynonym+ then error ("nontermination in lookupGPIName w/ path '" ++ show path ++ "' set to itself")+ else lookupGPIName pathSynonym trans+ _ -> notGPIError+ FGPI _ _ -> getShapeName (bvarToString v) field++lookupGPIName _ _ = notGPIError+notGPIError = error "Layering expressions can only operate on GPIs."++-- | Walk the translation to find all layering statements.+findLayeringExprs :: (Autofloat a) => Translation a -> [Expr]+findLayeringExprs t = foldSubObjs findLayeringExpr t+ where findLayeringExpr :: (Autofloat a) => String -> Field -> FieldExpr a -> [Expr] -> [Expr]+ findLayeringExpr name field fexpr acc =+ case fexpr of+ FExpr (OptEval x@(Layering _ _)) -> x : acc+ _ -> acc++-- | Calculates all the nodes that are part of cycles in a graph.+cyclicNodes :: Graph.Graph -> [Graph.Vertex]+cyclicNodes graph =+ map fst . filter isCyclicAssoc . assocs $ graph+ where+ isCyclicAssoc = uncurry $ reachableFromAny graph++-- | In the specified graph, can the specified node be reached, starting out+-- from any of the specified vertices?+reachableFromAny :: Graph.Graph -> Graph.Vertex -> [Graph.Vertex] -> Bool+reachableFromAny graph node =+ elem node . concatMap (Graph.reachable graph)++-- | 'topSortLayering' takes in a list of all GPI names and a list of directed edges [(a -> b)] representing partial layering orders as input and outputs a linear layering order of GPIs+topSortLayering :: [String] -> [(String, String)] -> [String]+topSortLayering names partialOrderings =+ let orderedNodes = nodesFromEdges partialOrderings+ freeNodes = Set.difference (Set.fromList names) orderedNodes+ edges = map (\(x, y) -> (x, x, y)) $ adjList partialOrderings+ ++ (map (\x -> (x, [])) $ Set.toList freeNodes)+ (graph, nodeFromVertex, vertexFromKey) = Graph.graphFromEdges edges+ cyclic = not . null $ cyclicNodes graph+ in if cyclic then error "The graph is cyclic!" else map (getNodePart . nodeFromVertex) $ Graph.topSort graph+ where+ getNodePart (n, _, _) = n++nodesFromEdges edges = Set.fromList $ concatMap (\(a, b) -> [a, b]) edges++adjList :: [(String, String)] -> [(String, [String])]+adjList edges =+ let nodes = Set.toList $ nodesFromEdges edges+ in map (\x -> (x, findNeighbors x)) nodes+ where findNeighbors node = map snd $ filter ((==) node . fst) edges++computeLayering :: (Autofloat a) => Translation a -> [String]+computeLayering trans =+ let layeringExprs = findLayeringExprs trans+ partialOrderings = map findNames layeringExprs+ gpiNames = map (uncurry getShapeName) $ findShapeNames trans+ in topSortLayering gpiNames partialOrderings+ where+ unused = -1+ substitute res (block, substs) =+ let block' = (block, unused)+ substs' = map (\s -> (s, unused)) substs+ in res ++ map (`substituteBlock` block') substs'+ findNames (Layering path1 path2) = (lookupGPIName path1 trans, lookupGPIName path2 trans)++------------- Main function: what the Style compiler generates++genOptProblemAndState :: Translation Double -> OptConfig -> State+genOptProblemAndState trans optConfig =+ -- Save information about the translation+ let !varyingPaths = findVarying trans in+ -- NOTE: the properties in uninitializedPaths are NOT floats. Floats are included in varyingPaths already+ let uninitializedPaths = findUninitialized trans in+ let pendingPaths = findPending trans in+ let shapeNames = findShapeNames trans in++ -- sample varying fields+ let (transInitFields, g') = initFields varyingPaths trans initRng in++ -- sample varying vals and instantiate all the non-float base properties of every GPI in the translation+ let (!transInit, g'') = initShapes transInitFields shapeNames g' in+ let shapeProperties = transInit `seq` findShapesProperties transInit in++ let (objfns, constrfns) = (toFns . partitionEithers . findObjfnsConstrs) transInit in+ let (defaultObjFns, defaultConstrs) = (toFns . partitionEithers . findDefaultFns) transInit in+ let (!objFnsWithDefaults, !constrsWithDefaults) = (objfns ++ defaultObjFns, constrfns ++ defaultConstrs) in+ -- let overallFn = genObjfn (castTranslation transInit) objFnsWithDefaults constrsWithDefaults varyingPaths in+ -- NOTE: this does NOT use transEvaled because it needs to be re-evaled at each opt step+ -- the varying values are re-inserted at each opt step++ -- Evaluate all expressions once to get the initial shapes+ let initVaryingMap = M.empty in -- No optimization has happened. Sampled varying vals are in transInit+ let (initialGPIs, transEvaled, _) = evalShapes evalIterRange (map (mkPath . list2) shapeNames) transInit initVaryingMap g'' in -- intentially discarding the new random feed, since we want the computation result to be consistent within one optimization session+ let initState = lookupPaths varyingPaths transEvaled in++ -- This is the final Style compiler output+ let s = State { shapesr = initialGPIs,+ shapeNames = shapeNames,+ shapeProperties = shapeProperties,+ shapeOrdering = [], -- NOTE: to be populated later+ transr = transInit, -- note: NOT transEvaled+ varyingPaths = varyingPaths,+ uninitializedPaths = uninitializedPaths,+ pendingPaths = pendingPaths,+ varyingState = initState,+ objFns = objFnsWithDefaults,+ constrFns = constrsWithDefaults,+ paramsr = Params { weight = initWeight,+ optStatus = NewIter,+ -- overallObjFn = overallFn,+ bfgsInfo = defaultBfgsParams },+ rng = g'',+ autostep = False, -- default+ policyParams = initPolicyParams,+ -- policyFn = policyToUse,+ oConfig = optConfig+ } in++ -- initPolicy -- TODO: rewrite to avoid the use of lambda functions+ s+ -- NOTE: we do not resample the very first initial state. Not sure why the shapes / labels are rendered incorrectly.+ -- resampleBest numStateSamples initFullState++-- | 'compileStyle' runs the main Style compiler on the AST of Style and output from the Substance compiler and outputs the initial state for the optimization problem. This function is a top-level function used by "Server" and "ShadowMain"+-- NOTE: this function also print information out to stdout+-- TODO: enable logger+compileStyle :: StyProg -> C.SubOut -> [J.StyVal] -> OptConfig -> IO State+compileStyle styProg (C.SubOut subProg (subEnv, eqEnv) labelMap) styVals optConfig = do+ putStrLn "Running Style semantics\n"+ let selEnvs = checkSels subEnv styProg++ putStrLn "Selector static semantics and local envs:\n"+ forM_ selEnvs pPrint+ divLine++ let subss = find_substs_prog subEnv eqEnv subProg styProg selEnvs+ putStrLn "Selector matches:\n"+ forM_ subss pPrint+ divLine++ let !trans = translateStyProg subEnv eqEnv subProg styProg labelMap styVals+ :: Either [Error] (Translation Double)+ -- NOT :: forall a . (Autofloat a) => Either [Error] (Translation a)+ -- We intentionally specialize/monomorphize the translation to Float so it can be fully evaluated+ -- and is not trapped under the lambda of the typeclass (Autofloat a) => ...+ -- This greatly improves the performance of the system. See #166 for more details.+-- let transAuto = castTranslation $ fromRight trans+-- :: forall a . (Autofloat a) => Translation a+ let transAuto = fromRight trans ++ putStrLn "Translated Style program:\n"+ pPrint trans+ divLine++ let initState = genOptProblemAndState transAuto optConfig+ putStrLn "Generated initial state:\n"+ print initState+ divLine++ -- global layering order computation+ let gpiOrdering = computeLayering transAuto+ putStrLn "Generated GPI global layering:\n"+ print gpiOrdering+ divLine++ let initState' = initState { shapeOrdering = gpiOrdering }++ putStrLn (bgColor Cyan $ style Italic " Style program warnings ")+ let warns = warnings transAuto+ putStrLn (color Red $ intercalate "\n" warns ++ "\n")+ return initState'++-- | After monomorphizing the translation's type (to make sure it's computed), we generalize the type again, which means+-- | it's again under a typeclass lambda. (#166)+castTranslation :: Translation Double -> (forall a . Autofloat a => Translation a)+castTranslation t =+ let res = M.map castFieldDict (trMap t) in+ t { trMap = res }+ where+ castFieldDict :: FieldDict Double -> (forall a . Autofloat a => FieldDict a)+ castFieldDict dict = M.map castFieldExpr dict++ castFieldExpr :: FieldExpr Double -> (forall a . (Autofloat a) => FieldExpr a)+ castFieldExpr e =+ case e of+ FExpr te -> FExpr $ castTagExpr te+ FGPI n props -> FGPI n $ M.map castTagExpr props++ castTagExpr :: TagExpr Double -> (forall a . Autofloat a => TagExpr a)+ castTagExpr e =+ case e of+ Done v -> Done $ castValue v+ Pending v -> Pending $ castValue v+ OptEval e -> OptEval e -- Expr only contains floats+ + + castValue :: Value Double -> (forall a . Autofloat a => Value a)+ castValue v = + let res = case v of+ FloatV x -> FloatV (r2f x)+ PtV (x, y) -> PtV (r2f x, r2f y)+ PtListV pts -> PtListV $ map (app2 r2f) pts+ PathDataV d -> PathDataV $ map castPath d+ -- More boilerplate not involving floats+ IntV x -> IntV x+ BoolV x -> BoolV x+ StrV x -> StrV x+ FileV x -> FileV x+ StyleV x -> StyleV x+ ColorV (RGBA r g b a) -> ColorV $ RGBA (r2f r) (r2f g) (r2f b) (r2f a)+ in res++ castPath :: Path' Double -> (forall a . Autofloat a => Path' a)+ castPath p = case p of+ Closed elems -> Closed $ map castElem elems+ Open elems -> Open $ map castElem elems++ castElem :: Elem Double -> (forall a . Autofloat a => Elem a)+ castElem e = case e of+ Pt pt -> Pt $ app2 r2f pt+ CubicBez pts -> CubicBez $ app3 (app2 r2f) pts+ CubicBezJoin pts -> CubicBezJoin $ app2 (app2 r2f) pts+ QuadBez pts -> QuadBez $ app2 (app2 r2f) pts+ QuadBezJoin pt -> QuadBezJoin $ app2 r2f pt++-------------------------------+-- Sampling code+-- TODO: should this code go in the optimizer?++numStateSamples :: Int+numStateSamples = 500++-- | Resample the varying state.+-- | We are intentionally using a monomorphic type (float) and NOT using the translation, to avoid slowness.+resampleVState :: [Path] -> [Shape Double] -> StdGen -> (([Shape Double], [Double], [Double]), StdGen)+resampleVState varyPaths shapes g =+ let (resampledShapes, rng') = sampleShapes g shapes+ (resampledFields, rng'') = resampleFields varyPaths rng'+ -- make varying map using the newly sampled fields (we do not need to insert the shape paths)+ varyMapNew = mkVaryMap (filter isFieldPath $ varyPaths) resampledFields+ varyingState = shapes2floats resampledShapes varyMapNew $ varyPaths+ in ((resampledShapes, varyingState, resampledFields), rng'')++-- | Update the translation to get the full state.+updateVState :: State -> (([Shape Double], [Double], [Double]), StdGen) -> State+updateVState s ((resampledShapes, varyingState', fields'), g) =+ let polyShapes = toPolymorphics resampledShapes+ uninitVals = map toTagExpr $ shapes2vals polyShapes $ uninitializedPaths s+ trans' = insertPaths (uninitializedPaths s) uninitVals (transr s)+ -- TODO: shapes', rng' = sampleConstrainedState (rng s) (shapesr s) (constrs s)+ varyMapNew = mkVaryMap (filter isFieldPath $ varyingPaths s) fields'+ -- TODO: this is not necessary for now since the label dimensions do not change, but added for completeness+ pendingPaths = findPending trans'+ in s { shapesr = polyShapes,+ rng = g,+ transr = trans' { warnings = [] }, -- Clear the warnings, since they aren't relevant anymore+ varyingState = map r2f varyingState',+ pendingPaths = pendingPaths,+ paramsr = (paramsr s) { weight = initWeight, optStatus = NewIter } }+ -- NOTE: for now we do not update the new state with the new rng from eval.+ -- The results still look different because resampling updated the rng.+ -- Therefore, we do not have to update rng here.++-- | Iterate a function that uses a generator, generating an infinite list of results with their corresponding updated generators.+iterateS :: (a -> (b, a)) -> a -> [(b, a)]+iterateS f g = let (res, g') = f g in+ (res, g') : iterateS f g'++-- | Compare two states and return the one with less energy.+lessEnergyOn :: ([Double] -> Double) -> (([Shape Double], [Double], [Double]), StdGen)+ -> (([Shape Double], [Double], [Double]), StdGen) -> Ordering+lessEnergyOn f ((_, vs1, _), _) ((_, vs2, _), _) = compare (f vs1) (f vs2)++-- | Resample the varying state some number of times (sampling each new state from the original state, but with an updated rng).+-- | Pick the one with the lowest energy and update the original state with the lowest-energy-state's info.+-- | NOTE: Assumes that n is greater than 1+resampleBest :: Int -> State -> State+resampleBest n s =+ let optInfo = paramsr s+ -- Take out the relevant information for resampling+ f = evalEnergyOn s+ (varyPaths, shapes, g) = (varyingPaths s, shapesr s, rng s)+ -- Partially apply resampleVState with the params that don't change over a resampling+ resampleVStateConst = resampleVState varyPaths shapes+ sampledResults = take n $ iterateS resampleVStateConst g+ res = minimumBy (lessEnergyOn f) sampledResults+ {- (trace ("energies: " ++ (show $ map (\((_, x, _), _) -> f x) sampledResults)) -}+ -- in initPolicy $ updateVState s res+ in updateVState s res++------- Other possibly-useful utility functions (not currently used)+-- TODO: rewrite these functions to not use the lambdaized overallObjFN++-- | Evaluate the objective function on the varying state (with the penalty weight, which should be the same between state).+-- evalFnOn :: State -> Double+-- evalFnOn s = let optInfo = paramsr s+-- f = (overallObjFn optInfo) (rng s) (float2Double $ weight optInfo)+-- args = varyingState s+-- in f args++-- | Compare two states and return the one with less energy.+-- lessEnergy :: State -> State -> Ordering+-- lessEnergy s1 s2 = compare (evalFnOn s1) (evalFnOn s2)++---------- List of policies that can be used with the optimizer++-- Policy stops when value is None+-- Note: if there are no objectives/constraints, policy may return an empty list of functions+-- Policy step = one optimization through to convergence+-- TODO: factor out number of policy steps / other boilerplate? or let it remain dynamic?+-- TODO: factor out the weights on the objective functions / method of combination (in genObjFn)++initPolicyParams :: PolicyParams+initPolicyParams = PolicyParams { policyState = "", policySteps = 0, currFns = [] }++-- initPolicy :: State -> State+-- initPolicy s = -- TODO: make this less verbose+-- let (policyRes, pstate) = (policyFn s) (objFns s) (constrFns s) initPolicyParams in+-- let newFns = DM.fromJust policyRes in+-- let stateWithPolicy = s { paramsr = (paramsr s) { overallObjFn = genObjfn (castTranslation $ transr s) (filter isObjFn newFns) +-- (filter isConstr newFns) (varyingPaths s) }, +-- policyParams = initPolicyParams { policyState = pstate, currFns = newFns } } in+-- stateWithPolicy++optimizeConstraints :: Policy+optimizeConstraints objfns constrfns params = + let (pstate, psteps) = (policyState params, policySteps params) in+ if psteps == 0 then (Just constrfns, "")+ else (Nothing, "") -- Take 1 policy step++optimizeObjectives :: Policy+optimizeObjectives objfns constrfns params =+ let (pstate, psteps) = (policyState params, policySteps params) in+ if psteps == 0 then (Just objfns, "")+ else (Nothing, "") -- Take 1 policy step++-- This is the typical/old Penrose policy+optimizeSumAll :: Policy+optimizeSumAll objfns constrfns params =+ let (pstate, psteps) = (policyState params, policySteps params) in+ if psteps == 0 then (Just $ objfns ++ constrfns, "")+ else (Nothing, "") -- Take 1 policy step++optimizeConstraintsThenObjectives :: Policy+optimizeConstraintsThenObjectives objfns constrfns params =+ let (pstate, psteps) = (policyState params, policySteps params) in+ if psteps == 0 then (Just constrfns, "Constraints") -- Initial policy state+ else if psteps >= 2 then (Nothing, "Done") -- Just constraints then objectives for now, then done+ else if pstate == "Constraints" then (Just objfns, "Objectives")+ else if pstate == "Objectives" then (Just constrfns, "Constraints")+ else error "invalid policy state"++isObjFn f = optType f == Objfn+isConstr f = optType f == Constrfn++-- TODO: does genObjFns work with an empty list?
+ src/Interface.hs view
@@ -0,0 +1,130 @@+module Interface where+{-# OPTIONS_HADDOCK prune #-}++import Control.Exception (ErrorCall, try)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy.Char8 as B+import Element+import Env+import GenOptProblem+import qualified Optimizer+import Plugins+import Serializer+import Style+import Substance+import Sugarer+import System.IO.Unsafe (unsafePerformIO)+import Utils++-- | Given Substance, Style, and Element programs, output an initial state.+-- TODO: allow cached intermediate outputs such as ASTs to be passed in?+compileTrio ::+ String -- ^ a Substance program+ -> String -- ^ a Style program+ -> String -- ^ an Element program+ -> Either CompilerError (State, VarEnv) -- ^ an initial state and compiler context for language services+compileTrio substance style element+ -- Parsing and desugaring phase+ = do+ env <- parseElement "" element+ styProg <- parseStyle "" style env+ let subDesugared = sugarStmts substance env -- TODO: errors?+ subOut@(SubOut _ (subEnv, _) _) <- parseSubstance "" subDesugared env+ -- Plugin phase+ pluginRes <- runPlugin subOut style env+ (subOut', styVals) <-+ case pluginRes of+ Nothing -> pure $ (subOut, [])+ Just (subPlugin, styVals) -> do+ subOutPlugin <-+ parseSubstance "" (subDesugared ++ "\n" ++ subPlugin) env+ return (subOutPlugin, styVals)+ -- Compilation phase+ let optConfig = defaultOptConfig+ let styRes =+ unsafePerformIO $ -- HACK: rewrite this such that it's safe+ try (compileStyle styProg subOut' styVals optConfig) :: Either ErrorCall State+ case styRes of+ Right initState -> Right (initState, subEnv)+ Left styRTError -> Left $ StyleTypecheck $ show styRTError++getEnv ::+ String -- ^ a Substance program+ -> String -- ^ an Element program+ -> Either CompilerError VarEnv -- ^ either a compiler error or an environment of the Substance program+getEnv substance element = do+ env <- parseElement "" element+ let subDesugared = sugarStmts substance env -- TODO: errors?+ subOut@(SubOut _ (subEnv, _) _) <- parseSubstance "" subDesugared env+ Right $ subEnv++step ::+ State -- ^ the initial state+ -> Int -- ^ the number of steps n for the optimizer to take+ -> Either RuntimeError State -- ^ the resulting state after the optimizer takes n steps+ -- TODO: rewrite runtime error reporting+step initState steps = Right $ iterate Optimizer.step initState !! (steps + 1) -- `iterate` applies `id` the first time++stepUntilConvergence ::+ State -- ^ the initial state+ -> Either RuntimeError State -- ^ the converged state or optimizer errors+stepUntilConvergence state+ | optStatus (paramsr state) == EPConverged = Right state+ -- TODO: rewrite runtime error reporting+ | otherwise = stepUntilConvergence $ Optimizer.step state++resample ::+ State -- ^ the initial state+ -> Int -- ^ number of samples to choose from (> 0). If it's 1, no selection will occur+ -> Either RuntimeError State -- ^ if the number of samples requested is smaller than 1, return error, else return the resulting state+resample initState numSamples+ | numSamples >= 1 =+ let newState = resampleBest numSamples initState+ (newShapes, _, _) = evalTranslation newState+ in Right $ newState {shapesr = newShapes}+ | otherwise = Left $ RuntimeError "At least 1 sample should be requested."++--------------------------------------------------------------------------------+-- Test+subFile = "sub/tree.sub"++styFile = "sty/venn.sty"++elmFile = "set-theory-domain/setTheory.dsl"++testCompile :: IO ()+testCompile = do+ sub <- readFile subFile+ sty <- readFile styFile+ elm <- readFile elmFile+ let res = compileTrio sub sty elm+ case res of+ Right state -> B.writeFile "state.json" $ A.encode state+ Left err -> putStrLn $ show err++testStep :: Bool -> IO ()+testStep converge+ | converge = do+ sub <- readFile subFile+ sty <- readFile styFile+ elm <- readFile elmFile+ let s = compileTrio sub sty elm+ case s of+ Right (state, _) ->+ let res = stepUntilConvergence state+ in case res of+ Right state' -> B.writeFile "state-step.json" $ A.encode state'+ Left err -> putStrLn $ show err+ Left err -> putStrLn $ show err+ | otherwise = do+ sub <- readFile subFile+ sty <- readFile styFile+ elm <- readFile elmFile+ let s = compileTrio sub sty elm+ case s of+ Right (state, _) ->+ let res = step state 2+ in case res of+ Right state' -> B.writeFile "state-step.json" $ A.encode state'+ Left err -> putStrLn $ show err+ Left err -> putStrLn $ show err
src/Main.hs view
@@ -1,83 +1,8 @@--- | Main module of the Penrose system-module Main where-import Graphics.Gloss-import Graphics.Gloss.Data.Vector-import Graphics.Gloss.Interface.Pure.Game-import qualified Server-import qualified Runtime as R-import qualified Compiler as C-import qualified StyAst as SA-import qualified Text.Megaparsec as MP (runParser, parseErrorPretty)-import System.Environment-import System.IO-import System.Exit-import Control.Monad(when)-+-- | Main module of the Penrose system (logic is moved to ShadowMain for testing) -divLine = putStr "\n--------\n\n"+module Main where+import ShadowMain -- | `main` runs the Penrose system main :: IO ()-main = do- -- Reading in from file- -- Objective function is currently hard-coded- -- Comment in (or out) this block of code to read from a file (need to fix parameter tuning!)- args <- getArgs- when (length args /= 3) $ die "Usage: ./Main <snap|gloss> prog1.sub prog2.sty"- let (mode, subFile, styFile) = (head args, args !! 1, args !! 2)- subIn <- readFile subFile- styIn <- readFile styFile- putStrLn "\nSubstance program:\n"- putStrLn subIn- divLine- putStrLn "Style program:\n"- putStrLn styIn- divLine-- let subParsed = C.subParse subIn- putStrLn "Parsed Substance program:\n"- putStrLn $ C.subPrettyPrint' subParsed-- case MP.runParser SA.styleParser styFile styIn of- Left err -> putStr $ MP.parseErrorPretty err- Right styParsed -> do- divLine- putStrLn "Parsed Style program:\n"- -- putStrLn $ C.styPrettyPrint styParsed- mapM_ print styParsed- divLine- let initState = R.genInitState (C.subSeparate subParsed) styParsed- putStrLn "Synthesizing objects and objective functions"- -- let initState = compilerToRuntimeTypes intermediateRep- -- divLine- -- putStrLn "Initial state, optimization representation:\n"- -- putStrLn "TODO derive Show"- -- putStrLn $ show initState-- divLine- putStrLn "Visualizing notation:\n"-- if mode == "snap" then- -- Starting serving penrose on the web- let (domain, port) = ("127.0.0.1", 9160) in- Server.servePenrose domain port initState-- else- -- Running with hardcoded parameters- play- (InWindow "optimization-based layout" -- display mode, window name- (picWidth, picHeight) -- size- (10, 10)) -- position- white -- background color- R.stepsPerSecond -- number of simulation steps to take for each second of real time- initState -- the initial world, defined as a type below- R.picOf -- fn to convert world to a pic- R.handler -- fn to handle input events- R.step -- step the world one iteration; passed period of time (in secs) to be advanced--picWidth, picHeight :: Int-picWidth = 800-picHeight = 700--stepsPerSecond :: Int-stepsPerSecond = 10000+main = shadowMain
+ src/Optimizer.hs view
@@ -0,0 +1,510 @@+{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction #-}+{-# LANGUAGE BangPatterns, FlexibleInstances #-}+{-# OPTIONS_HADDOCK prune #-}++module Optimizer where++import Utils+import Style+import GenOptProblem+import Numeric.AD+import Numeric.AD.Internal.On+import Numeric.AD.Internal.Reverse+import Numeric.AD.Internal.Sparse+import qualified Numeric.LinearAlgebra as L+import Debug.Trace+import System.Random+import System.Console.ANSI+import Data.List (foldl')++default (Int, Double)++------ Opt types, util functions, and params++type ObjFn1 a = forall a . (Autofloat a) => [a] -> a++-- used for duf+type ObjFn2 a = forall a . (Autofloat a) => [a] -> [a] -> a++type GradFn a = forall a . (Autofloat a) => [a] -> [a]++----- Various consts++nanSub :: (Autofloat a) => a+nanSub = 0++infinity :: Floating a => a+infinity = 1/0 -- x/0 == Infinity for any x > 0 (x = 0 -> Nan, x < 0 -> -Infinity)+-- all numbers are smaller than infinity except infinity, to which it's equal++----- Hyperparameters++weightGrowthFactor :: (Autofloat a) => a -- for EP weight+weightGrowthFactor = 10++epsUnconstr :: Floating a => a+epsUnconstr = 10 ** (-2)++epStop :: Floating a => a -- for EP diff+epStop = 10 ** (-3)+-- epStop = 10 ** (-5)+-- epStop = 60 ** (-3)+-- epStop = 10 ** (-1)+-- epStop = 0.05++-- Parameters for Armijo-Wolfe line search+-- NOTE: must maintain 0 < c1 < c2 < 1+c1 :: Floating a => a+c1 = 0.001 -- for Armijo, corresponds to alpha in backtracking line search (see below for explanation)+-- smaller c1 = shallower slope = less of a decrease in fn value needed = easier to satisfy+-- turn Armijo off: c1 = 0+-- Nocedal p38: "In practice, c1 is chosen to be quite small, say 10−4."++c2 :: Floating a => a+c2 = 0.9 -- for Wolfe, is the factor decrease needed in derivative value+-- new directional derivative value / old DD value <= c2+-- smaller c2 = smaller new derivative value = harder to satisfy+-- turn Wolfe off: c1 = 1 (basically backatracking line search only)+-- Nocedal p39: "Typical values of c2 are 0.9 when the search direction pk is chosen by a Newton or quasi-Newton method"++-- true = force linesearch halt if interval gets too small; false = no forced halt+intervalMin = True++useLineSearch :: Bool+useLineSearch = True++useAutodiff :: Bool+useAutodiff = True++constT :: Floating a => a+constT = 0.001++-- debugOpt = True+debugOpt = False+debugLineSearch = False+debugBfgs = False++trb :: String -> a -> a+trb s x = if debugBfgs then trace "---" $ trace s x else x -- prints in left to right order++tro :: String -> a -> a+tro s x = if debugOpt then trace "---" $ trace s x else x -- prints in left to right order++trl :: Show a => String -> a -> a+trl s x = if debugLineSearch then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order++----- Convergence criteria++-- convergence criterion for EP+-- if you want to use it for UO, needs a different epsilon+epStopCond :: (Autofloat a) => [a] -> [a] -> a -> a -> Bool+epStopCond x x' fx fx' =+ tro ("EP: \n||x' - x||: " ++ (show $ norm (x -. x'))+ ++ "\n|f(x') - f(x)|: " ++ (show $ abs (fx - fx'))) $+ (norm (x -. x') <= epStop) || (abs (fx - fx') <= epStop)++unconstrainedStopCond :: (Autofloat a) => [a] -> Bool+unconstrainedStopCond gradEval = norm gradEval < epsUnconstr++---------------------------------------++-- Policies++-- stepPolicy :: State -> (Params, PolicyParams)+-- stepPolicy s = +-- -- Check overall convergence first +-- let epStatus = optStatus $ (paramsr s) in+-- let pparams = policyParams s in+-- case epStatus of++-- -- Generate new objective function and replace the optimization and policy params accordingly+-- EPConverged -> +-- -- TODO: clean up the step incrementing+-- let pparams' = pparams { policySteps = 1 + policySteps pparams } in+-- let (policyRes, psNew) = (policyFn s) (objFns s) (constrFns s) pparams' in -- See what the policy function wants+-- case policyRes of+-- Nothing -> (paramsr s, pparams' { policyState = psNew }) -- steps incremented, policy done++-- Just newFns -> -- Policy keeps going+-- let objFnNew = genObjfn (castTranslation $ transr s) (filter isObjFn newFns) (filter isConstr newFns) (varyingPaths s) +-- -- TODO: check that these inputs are right+-- -- Change obj function and restart optimization+-- pparamsNew = pparams' { policyState = psNew,+-- currFns = newFns }+-- paramsNew = Params { weight = initWeight,+-- optStatus = NewIter,+-- overallObjFn = objFnNew,+-- bfgsInfo = defaultBfgsParams }+-- in tro ("Step policy, EP converged, new params:\n" ++ show (paramsNew, pparamsNew, newFns)) $ (paramsNew, pparamsNew)++-- -- If not converged, optimize as usual, don't change policy mid-optimization+-- _ -> tro ("Step policy, EP not converged, new params:\n" ++ show (paramsr s, pparams)) $ (paramsr s, pparams)++---------------------------------------++-- Main optimization functions++step :: State -> State+step s = let (state', params') = stepShapes s+-- (oConfig s) (paramsr s) (varyingState s) (rng s)+ s' = s { varyingState = state', + paramsr = params' }+ -- NOTE: we intentionally discard the random generator here because+ -- we want to have consistent computation output in a single+ -- optimization session+ -- For the same reason, all subsequent step* functions such as+ -- stepShapes do not return the new random generator+ (!shapes', _, _) = evalTranslation s'++ -- Check the state and see if the overall objective function should be changed+ -- The policy may change EPConverged to a new iteration before the frontend sees it+ -- (paramsNew, pparamsNew) = stepPolicy s'++ -- For debugging+ oldParams = paramsr s++ in tro ("Params: \n" ++ show oldParams ++ "\n:") $+ s' { + -- shapesr = shapes',+ -- paramsr = paramsNew,+ -- policyParams = pparamsNew } + shapesr = shapes',+ paramsr = params' }+ -- note: trans is not updated in state++-- Note use of realToFrac to generalize type variables (on the weight and on the varying state)++-- implements exterior point algo as described on page 6 here:+-- https://www.me.utexas.edu/~jensen/ORMM/supplements/units/nlp_methods/const_opt.pdf+stepShapes :: State -> ([Double], Params)+stepShapes s = -- varying state+ -- if null vstate then error "empty state in stepshapes" else+ let (epWeight, epStatus) = (weight params, optStatus params) in+ case epStatus of++ -- start the outer EP optimization and the inner unconstrained optimization, recording initial EPstate+ NewIter -> let status' = UnconstrainedRunning (map realToFrac vstate) in+ (vstate', params { weight = initWeight, optStatus = status', bfgsInfo = defaultBfgsParams } )+ -- check *weak* convergence of inner unconstrained opt.+ -- if UO converged, set opt state to converged and update UO state (NOT EP state)+ -- if not, keep running UO (inner state implicitly stored)+ -- note convergence checks are only on the varying part of the state+ UnconstrainedRunning lastEPstate -> -- doesn't use last EP state+ -- let unconstrConverged = unconstrainedStopCond gradEval in+ let unconstrConverged = epStopCond vstate vstate' (objFnApplied vstate) (objFnApplied vstate') in+ -- Two stopping conditions+ -- unconstrainedStopCond gradEval in+ if unconstrConverged then+ let status' = UnconstrainedConverged lastEPstate in -- update UO state only!+ (vstate', params { optStatus = status', bfgsInfo = defaultBfgsParams }) -- note vstate' (UO converged), not vstate+ else (vstate', params { bfgsInfo = bfgs' }) -- update UO state but not EP state; UO still running++ -- check EP convergence. if converged then stop, else increase weight, update states, and run UO again+ -- TODO some trickiness about whether unconstrained-converged has updated the correct state+ -- and whether to check WRT the updated state or not+ UnconstrainedConverged lastEPstate ->+ let epConverged = epStopCond lastEPstate (map r2f vstate) -- lastEPstate is last state for converged UO+ (objFnApplied lastEPstate) (objFnApplied (map r2f vstate)) in+ if epConverged then+ let status' = EPConverged in -- no more EP state+ (vstate, params { optStatus = status', bfgsInfo = defaultBfgsParams }) -- do not update UO state+ -- update EP state: to be the converged state from the most recent UO+ else let status' = UnconstrainedRunning (map realToFrac vstate) in -- increase weight+ let epWeight' = weightGrowthFactor * epWeight in+ -- trace ("Unconstrained converged. New weight: " ++ show epWeight') $+ (vstate, params { weight = epWeight', optStatus = status', bfgsInfo = defaultBfgsParams })++ -- done; don't update obj state or params; user can now manipulate+ EPConverged -> (vstate, params { bfgsInfo = defaultBfgsParams } )++ -- TODO: implement EPConvergedOverride (for when the magnitude of the gradient is still large)++ -- TODO factor out--only unconstrainedRunning needs to run stepObjective, but EPconverged needs objfn+ where + (config, params, vstate, g) = (oConfig s, paramsr s, varyingState s, rng s) + (vstate', gradEval, bfgs') = stepWithObjective s+ -- objFnApplied = (overallObjFn params) g (r2f $ weight params)+ objFnApplied = evalEnergyOn s++-- Given the time, state, and evaluated gradient (or other search direction) at the point,+-- return the new state++stepT :: Double -> Double -> Double -> Double+stepT dt x dfdx = x - dt * dfdx++-- Calculates the new state by calculating the directional derivatives (via autodiff)+-- and timestep (via line search), then using them to step the current state.+-- Also partially applies the objective function.+stepWithObjective :: State -> ([Double], [Double], BfgsParams)+stepWithObjective s =+ -- get timestep via line search, and evaluated gradient at the state+ let (t', gradEval, gradToUse, bfgs') = timeAndGrad config params objFnApplied state+ -- step each parameter of the state with the time and gradient+ state' = map (\(v, dfdv) -> stepT t' v dfdv) (zip state $ gradToUse)+ (fx, fx') = (objFnApplied state, objFnApplied state') + in -- if fx' > fx then error ("Error: new energy is greater than old energy: " ++ show (fx', fx)) else+ tro ("\n----------------------------------------\n"+ ++ "\nopt params: \n" ++ (show params)+ ++ "\n||x' - x||: " ++ (show $ norm (state -. state'))+ ++ "\n|f(x') - f(x)|: " +++ (show $ abs (fx' - fx))+ ++ "\nf(x'): \n" ++ (show fx')+ ++ "\ngradEval: \n" ++ (show gradEval)+ ++ "\n||gradEval||: \n" ++ (show $ norm gradEval)+ ++ "\ngradToUse: \n" ++ (show gradToUse)+ ++ "\n||gradToUse||: \n" ++ (show $ norm gradToUse)+ -- ++ "\nhessian: \n" ++ (show $ h)+ ++ "\nbfgs': \n" ++ (show bfgs') -- TODO: use trb+ ++ "\n timestep: \n" ++ (show t')+ ++ "\n original state: \n" ++ (show state)+ ++ "\n new state: \n" ++ (show state')+ )+ (state', gradEval, bfgs')++ where + (config, params, state, g) = (oConfig s, paramsr s, varyingState s, rng s)+ -- objFnApplied :: ObjFn1 b+ -- objFnApplied = (overallObjFn params) g cWeight+ objFnApplied = evalEnergyOn s+ cWeight = r2f $ weight params+ -- realToFrac generalizes the type variable `a` to the type variable `b`, which timeAndGrad expects++-- a version of grad with a clearer type signature+appGrad :: (Autofloat a) => (forall b . (Autofloat b) => [b] -> b) -> [a] -> [a]+appGrad f l = grad f l++instance Show (Numeric.AD.Internal.On.On+ (Numeric.AD.Internal.Reverse.Reverse+ s (Numeric.AD.Internal.Sparse.Sparse a))) where+ show a = "error: not sure how to derive show for hessian element"++appHess :: (Autofloat a) => (forall b . (Autofloat b) => [b] -> b) -> [a] -> [[a]]+appHess f l = hessian f l++-- Precondition the gradient+gradP :: OptConfig -> BfgsParams -> [Double] -> ObjFn1 a -> [Double] -> ([Double], BfgsParams)+gradP config bfgsParams gradEval f state =+ let x_k = L.vector $ map r2f state+ grad_fx_k = L.vector gradEval+ in case optMethod config of + GradientDescent -> (gradEval, bfgsParams)++ Newton -> -- Precondition gradient with the pseudoinverse of the hessian+ let h = appHess f state+ h_list = (map r2f $ concat h) :: [Double]+ hinv = L.pinv $ L.matrix (length gradEval) $ h_list+ gradPreconditioned = hinv L.#> (L.vector gradEval) in+ (L.toList gradPreconditioned, bfgsParams)++ BFGS -> -- Approximate inverse of hessian with the change in gradient (see Nocedal S9.1 p224)+ let grad_val = lastGrad bfgsParams :: Maybe [Double]+ h_val = invH bfgsParams :: Maybe [[Double]]+ state_val = lastState bfgsParams :: Maybe [Double]+ in case (h_val, grad_val, state_val) of+ (Nothing, Nothing, Nothing) -> -- First step. Initialize the approximation to the identity (not clear how else to approximate it)+ -- k=0 steps from x_0 to x_1: so on the first step, we take a normal gradient descent step+ let h_0 = L.ident $ length gradEval+ in (gradEval, bfgsParams { lastState = Just $ L.toList x_k, lastGrad = Just $ L.toList grad_fx_k, invH = Just $ L.toLists h_0 })++ (Just h_km1L, Just grad_fx_km1L, Just x_km1L) -> -- For x_{k+1}, to compute H_k, we need the (k-1) info+ -- Our convention is that we are always working "at" k to compute k+1+ -- x_0 doesn't require any H; x_1 (the first step) with k = 0 requires H_0+ -- x_2 (the NEXT step) with k=1 requires H_1. For example>+ -- x_2 = x_1 - alpha_1 H_1 grad f(x_1) [GD step]+ -- H_1 = V_0 H_0 V_0 + rho_0 s_0 s_0^T [This is confusing because the book adds an extra +1 to the H index]+ -- V_0 = I - rho_0 y_0 s_0^T+ -- rho_0 = 1 / y_0^T s_0+ -- s_0 = x_1 - x_0+ -- y_0 = grad f(x_1) - grad f(x_0)++ let (h_km1, grad_fx_km1, x_km1) = (L.fromLists h_km1L, L.vector grad_fx_km1L, L.vector x_km1L) in+ let s_km1 = x_k - x_km1+ y_km1 = grad_fx_k - grad_fx_km1+ rho_km1 = 1 / (y_km1 `L.dot` s_km1) -- Scalar+ v_km1 = L.ident (length gradEval) - (rho_km1 `L.scale` y_km1 `L.outer` s_km1) -- Scaling can happen before outer+ h_k = (L.tr (v_km1) L.<> h_km1 L.<> v_km1) + (rho_km1 `L.scale` s_km1 `L.outer` s_km1)+ gradPreconditioned = h_k L.#> grad_fx_k+ in (L.toList gradPreconditioned, + bfgsParams { lastState = Just $ L.toList x_k, lastGrad = Just $ L.toList grad_fx_k, invH = Just $ L.toLists h_k })++ _ -> error "invalid BFGS state"++ LBFGS -> -- Approximate the inverse of the Hessian times the gradient+ -- Only using the last `m` gradient/state difference vectors, not building the full h_k matrix (Nocedal p226)+ let grad_prev = lastGrad bfgsParams+ x_prev = lastState bfgsParams+ ss_val = s_list bfgsParams+ ys_val = y_list bfgsParams+ km1 = numUnconstrSteps bfgsParams -- Our current step is k; the last step is km1 (k_minus_1)+ m = memSize bfgsParams+ in case (grad_prev, x_prev, ss_val, ys_val, km1) of++ -- Perform normal gradient descent on first step+ (Nothing, Nothing, [], [], 0) ->+ -- Store x_k, grad f(x_k) so we can compute s_k, y_k on next step+ let bfgsParams' = bfgsParams { lastState = Just $ L.toList x_k, lastGrad = Just $ L.toList grad_fx_k, + s_list = [], y_list = [], numUnconstrSteps = km1 + 1 } in+ (gradEval, bfgsParams')++ (Just grad_fx_km1L, Just x_km1L, ssL, ysL, km1) -> + let (grad_fx_km1, x_km1, ss, ys) = (L.fromList grad_fx_km1L, L.fromList x_km1L, map L.fromList ssL, map L.fromList ysL) in+ -- Compute s_{k-1} = x_k - x_{k-1} and y_{k-1} = (analogous with grads)+ -- Unlike Nocedal, compute the difference vectors first instead of last (same result, just a loop rewrite)+ -- Use the updated {s_i} and {y_i}. (If k < m, this reduces to normal BFGS, i.e. we use all the vectors so far)+ let (s_km1, y_km1) = (x_k - x_km1, grad_fx_k - grad_fx_km1) -- Newest vectors added to front+ (ss', ys') = (take m $ s_km1 : ss, take m $ y_km1 : ys) -- The limited-memory part: drop stale vectors+ gradPreconditioned = lbfgs grad_fx_k ss' ys'+ descentDirCheck = -gradPreconditioned `L.dot` grad_fx_k++ -- Reset L-BFGS if the result is not a descent direction, and use steepest descent direction+ -- https://github.com/JuliaNLSolvers/Optim.jl/issues/143 https://github.com/JuliaNLSolvers/Optim.jl/pull/144++ in if descentDirCheck < epsd + then (L.toList gradPreconditioned, bfgsParams { lastState = Just $ L.toList x_k, lastGrad = Just $ L.toList grad_fx_k,+ s_list = map L.toList ss', y_list = map L.toList ys', numUnconstrSteps = km1 + 1 })+ else tro "L-BFGS did not find a descent direction. Resetting correction vectors." $+ (gradEval, bfgsParams { lastState = Just $ L.toList x_k, lastGrad = Just $ L.toList grad_fx_k,+ s_list = [], y_list = [], numUnconstrSteps = km1 + 1 })++ -- TODO: check the curvature condition y_k^T s_k > 0 (8.7) (Nocedal 201)+ -- https://github.com/JuliaNLSolvers/Optim.jl/issues/26++ _ -> error "invalid L-BFGS state"++type LVector = L.Vector L.R+type LMatrix = L.Matrix L.R++-- See Nocedal p225+-- expects ys and ss to be in order from most recent to oldest (k-1 ... k-m)+-- expects length ys == length ss, length ys > 0, length ys > 0+lbfgs :: LVector -> [LVector] -> [LVector] -> LVector+lbfgs grad_fx_k ss ys =+ let rhos = map calculate_rho $ zip ss ys -- The length of any list should be the number of stored vectors+ q_k = grad_fx_k+ (q_k_minus_m, alphas) = foldl' pull_q_back (q_k, []) (zip3 rhos ss ys) -- backward: for i = k-1 ... k-m+ -- Note the order of alphas will be from k-m through k-1 for the push_r_forward loop+ h_0_k = estimate_hess (head ys) (head ss)+ r_k_minus_m = h_0_k L.#> q_k_minus_m+ r_k = foldl' push_r_forward r_k_minus_m (zip (zip (reverse rhos) alphas) (zip (reverse ss) (reverse ys)))+ -- forward: for i = k-m .. k-1 (TODO: optimize out the reverses)+ in r_k -- is H_k * grad f(x_k)++ where calculate_rho :: (LVector, LVector) -> L.R+ calculate_rho (s, y) = 1 / ((y `L.dot` s) + epsd)++ pull_q_back :: (LVector, [L.R]) -> (L.R, LVector, LVector) -> (LVector, [L.R]) -- from i+1 to i+ pull_q_back (q_i_plus_1, alphas) (rho_i, s_i, y_i) =+ let alpha_i = rho_i * (s_i `L.dot` q_i_plus_1) -- scalar+ q_i = q_i_plus_1 - (alpha_i `L.scale` y_i) -- scalar * vector+ in (q_i, alpha_i : alphas) -- Note the order of alphas++ -- Scale I by an estimate of the size of the Hessian along the most recent search direction (Nocedal p226)+ estimate_hess :: LVector -> LVector -> LMatrix+ estimate_hess y_km1 s_km1 = + let gamma_k = (s_km1 `L.dot` y_km1) / ((y_km1 `L.dot` y_km1) + epsd)+ in gamma_k `L.scale` (L.ident (L.size y_km1))++ push_r_forward :: LVector -> ((L.R, L.R), (LVector, LVector)) -> LVector -- from i to i+1+ push_r_forward r_i ((rho_i, alpha_i), (s_i, y_i)) =+ let beta_i = rho_i * (y_i `L.dot` r_i) -- scalar+ r_i_plus_1 = r_i + (alpha_i - beta_i) `L.scale` s_i -- scalar * vector+ in r_i_plus_1++estimateGradient :: ObjFn1 a -> [Double] -> [Double]+estimateGradient f state =+ let len = length state+ h = 0.001 -- Choice of h really matters!!! This is not an accurate estimate.+ fx = f state+ -- time is O(|state|^2)+ dfx i = ((f $ replace i ((state !! i) + h) state) - fx) / h+ dfxs = map dfx [0..(len-1)]+ in dfxs+ where replace pos newVal list = take pos list ++ newVal : drop (pos+1) list++-- Given the objective function, gradient function, timestep, and current state,+-- return the timestep (found via line search) and evaluated gradient at the current state.+-- the autodiff library requires that objective functions be polymorphic with Floating a+timeAndGrad :: OptConfig -> Params -> ObjFn1 a -> [Double] -> (Double, [Double], [Double], BfgsParams)+timeAndGrad config params f state = + let gradEval = if useAutodiff then gradF state else estimateGradient f state+ (gradToUse_d, bfgs') = gradP config (bfgsInfo params) (map r2f gradEval :: [Double]) f state+ gradToUse = map r2f gradToUse_d+ -- Use line search to find a good timestep. If we use Newton's method, the descent direction uses the preconditioned gradient.+ descentDir = negL $ gradToUse+ timestep = let resT = if useLineSearch && useAutodiff+ then awLineSearch config f (duf descentDir) descentDir state+ else constT in -- hardcoded timestep+ if isNaN resT then error "returned timestep is NaN" else resT+ + in tr "timeAndGrad: " (timestep, gradEval, gradToUse, bfgs')++ where gradF :: GradFn a+ gradF = appGrad f++ -- directional derivative of f at x in the direction of u (descent direction, which may not have unit norm)+ duf :: (Autofloat a) => [a] -> [a] -> a+ duf u x = u `dotL` gradF x++linesearch_max :: Int+linesearch_max = 100 -- TODO what's a reasonable limit (if any)?++-- Implements Armijo-Wolfe line search as specified in Keenan's notes, converges on nonconvex fns as well+-- based off Lewis & Overton, "Nonsmooth optimization via quasi-Newton methods+-- duf = D_u(f), the directional derivative of f at descent direction u+-- D_u(x) = <gradF(x), u>. If u = -gradF(x) (as it is here), then D_u(x) = -||gradF(x)||^2++awLineSearch :: OptConfig -> ObjFn1 a -> ObjFn1 a -> [Double] -> [Double] -> Double+awLineSearch config f duf descentDir x0 =++ let (a0, b0, t0) = (0, infinity, 1) -- Unit step length should be tried first for quasi-Newton methods. (Nocedal 201)++ -- drop while a&w are not satisfied OR the interval is large enough+ (numUpdates, (af, bf, tf)) = head $ dropWhile intervalOK_or_notArmijoAndWolfe+ $ zip [0..] $ iterate update (a0, b0, t0)++ in tro ("Line search # updates: " ++ show numUpdates) $ tf++ where update :: (Double, Double, Double) -> (Double, Double, Double)+ update (a, b, t) =+ let (a', b', sat) | not $ armijo t = trl "not armijo" (a, t, False)+ | not $ wolfe t = trl "not wolfe" (t, b, False)+ | otherwise = (a, b, True) in+ if sat then (a, b, t) -- if armijo and wolfe, then we use (a, b, t) as-is+ else if b' < infinity then trl "b' < infinity" (a', b', (a' + b') / 2)+ else trl "b' = infinity" (a', b', 2 * a')++ intervalOK_or_notArmijoAndWolfe :: (Int, (Double, Double, Double)) -> Bool+ intervalOK_or_notArmijoAndWolfe (numUpdates, (a, b, t)) =+ not $+ if armijo t && wolfe t then+ trl ("stop: both sat. |descentDir at x0| = " ++ show (norm descentDir)) True+ else if abs (b - a) < minInterval then+ trl ("stop: interval too small. |descentDir at x0| = " ++ show (norm descentDir)) True+ else if numUpdates > linesearch_max then+ trl ("stop: number of line search updates exceeded max") True+ else False++ armijo :: Double -> Bool+ armijo t = (f (x0 +. t *. descentDir)) <= (fAtx0 + c1 * t * dufAtx0)++ weakWolfe :: Double -> Bool -- Better for nonsmooth functions+ weakWolfe t = (duf (x0 +. t *. descentDir)) >= (c2 * dufAtx0)++ strongWolfe :: Double -> Bool+ strongWolfe t = (abs (duf (x0 +. t *. descentDir))) <= (c2 * abs dufAtx0)++ -- Descent direction (at x0) must have a negative dot product with the gradient of f at x0.+ dufAtx0 :: Double -- TODO: this is redundant, cache it+ dufAtx0 = let res = duf x0 in+ trl ("<grad f(x0), descent direction at x0>: " ++ show res) $ + if res > 0 then tro "WARNING: descent direction doesn't satisfy condition" res else res++ fAtx0 :: Double+ fAtx0 = f x0++ minInterval :: Double -- stop if the interval gets too small; might not terminate+ minInterval = if intervalMin then 10 ** (-10) else 0+ -- TODO: the line search is very sensitive to this parameter. Blows up with 10**(-5). Why?++ wolfe :: Double -> Bool+ wolfe = weakWolfe
+ src/Plugins.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_HADDOCK prune #-}++module Plugins where++import Control.Exception (ErrorCall, try)+import Data.Aeson (decode)+import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.Map.Strict as M+import Env+import Style+import Substance+import SubstanceJSON+import System.Directory (getCurrentDirectory,+ setCurrentDirectory)+import System.IO.Unsafe (unsafePerformIO)+import System.Process (callCommand)+import Utils++--------------------------------------------------------------------------------+-- | 'runPlugin' parses plugin statements from the style program and executes+-- the plugin if one is found. It returns 'Nothing' of there is no plugin found,+-- returns an error if more than one is found, or returns a new Substance program+-- and some Style values if the plugin runs successfully.+runPlugin ::+ SubOut+ -> String+ -> VarEnv+ -> Either CompilerError (Maybe (String, [StyVal]))+runPlugin subOut stySrc elementEnv+ -- Find Substance instantiator plugin (if it exists in Style file + directory)+ = do+ instantiations <- parsePlugins "" stySrc elementEnv+ -- If 1 instantiation, run the plugin, append the resulting Substance program, re-check the full program, and use it in the Style compiler.+ -- If >1 instantiation, throw an error.+ case instantiations of+ [] -> Right $ Nothing+ [pluginName] ->+ let res = unsafePerformIO $ try (instantiateSub pluginName subOut)+ in case res of+ Right (subPlugin, styVals) -> Right $ Just $ (subPlugin, styVals)+ Left err -> Left $ PluginRun $ show (err :: ErrorCall)+ _ ->+ Left $ PluginParse $ "Multiple plugins found in Style; only one allowed."++-- If no instantiations, proceed with Style compiler.+-- putStrLn $ "instantiations found: " ++ (show instantiations)+--------------------------------------------------------------------------------+-- | 'pluginDict' stores the mappings from plugin names to commands to run+-- First entry: plugin name+-- Second entry: plugin directory (relative path OK), no trailing "/"+-- Third entry: command to run, relative to plugin directory+-- TODO: the standard should probably include `configure` and `run`, not just `run`+pluginDict :: M.Map String (String, String)+pluginDict =+ M.fromList+ [ ("haskell-test", ("plugins/haskell-instantiator", "./Main"))+ , ("ddgjs", ("plugins/mesh-plugin", "node mesh-plugin.js"))+ , ("alloy", ("plugins/alloy", "java -cp \"*:.\" AlloyPlugin"))+ , ("raytracing", ("TODO: path", "TODO: command"))+ ]++--------------------------------------------------------------------------------+-- Substance instantiation / plugin calls+-- Don't forget to recompile the plugin!+type SubstanceRaw = String++-- TODO: add more error checking to deal with paths or files that don't exist+-- TODO: this functions requires "values.json", which is not outputed by some plugins+instantiateSub :: String -> SubOut -> IO (SubstanceRaw, [StyVal])+instantiateSub pluginName parsedSub = do+ originalDir <- getCurrentDirectory+ let (dirPath, pluginCmd) =+ catchPathError pluginName (M.lookup pluginName pluginDict)+ putStrLn $ "plugin directory: " ++ dirPath+ putStrLn $ "plugin command: " ++ pluginCmd+ -- NOTE: we are not expecting multiple processes to use these tempfiles+ let outFile = dirPath ++ "/Sub_enduser.json"+ let subInFile = dirPath ++ "/Sub_instantiated.sub"+ let styInFile = dirPath ++ "/values.json"+ writeSubstanceToJSON outFile parsedSub+ setCurrentDirectory dirPath -- Change to plugin dir so the plugin gets the right path. Otherwise pwd sees "penrose/src"+ callCommand pluginCmd+ setCurrentDirectory originalDir -- Return to original directory+ newSubProg <- readFile subInFile+ styVals <- readFile styInFile+ styVals' <- B.readFile styInFile+ putStrLn "Penrose received Sub file: "+ putStrLn newSubProg+ putStrLn "---------------------------"+ putStrLn "Penrose received Sty file: "+ putStrLn styVals+ let styRes = (decode styVals') :: Maybe [StyVal]+ let styJSON =+ case styRes of+ Nothing -> error "couldn't read plugin JSON"+ Just x -> x+ return (newSubProg, styJSON)++catchPathError :: String -> Maybe (FilePath, String) -> (FilePath, String)+catchPathError name Nothing =+ error $ "path to plugin '" ++ name ++ "' doesn't exist!"+catchPathError _ (Just x) = x
− src/Runtime.hs
@@ -1,1828 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}--- for autodiff, requires passing in a polymorphic fn--module Runtime where-import Shapes-import Functions-import Utils-import Graphics.Gloss.Data.Vector-import Graphics.Gloss.Interface.Pure.Game-import Data.Function-import System.Random--- import Debug.Trace-import Numeric.AD-import GHC.Float -- float <-> double conversions-import System.IO-import System.Environment-import System.Exit-import Data.Set (fromList)-import Data.List-import Data.Maybe-import qualified Data.Map.Strict as M-import qualified Compiler as C-import qualified StyAst as SA- -- (subPrettyPrint, styPrettyPrint, subParse, styParse)- -- TODO limit export/import--- For running the new style parser-import qualified Text.Megaparsec as MP (runParser, parseErrorPretty)--- For porting to the web-import Data.Monoid ((<>))-import Data.Aeson--divLine = putStr "\n--------\n\n"--picWidth, picHeight :: Int-picWidth = 800-picHeight = 700--stepsPerSecond :: Int-stepsPerSecond = 100000--calcTimestep :: Float -- for use in forcing stepping in handler-calcTimestep = 1 / int2Float stepsPerSecond---data LastEPstate = EPstate [Obj] deriving (Eq, Show)--data OptStatus = NewIter -- TODO should this be init with a state?- | UnconstrainedRunning LastEPstate -- [Obj] stores last EP state- | UnconstrainedConverged LastEPstate -- [Obj] stores last EP state- | EPConverged- deriving (Eq, Show)--data Params = Params { weight :: Double,- optStatus :: OptStatus,- objFn :: forall a. ObjFnPenaltyState a,- annotations :: [[Annotation]]- } -- deriving (Eq, Show) -- TODO derive Show instance---- State of the world-data State = State { objs :: [Obj]- -- , stys :: [C.StyLine]- , constrs :: [C.SubConstr]- , down :: Bool -- left mouse button is down (dragging)- , rng :: StdGen -- random number generator- , autostep :: Bool -- automatically step optimization or not- , params :: Params- } -- deriving (Show)----------initRng :: StdGen-initRng = mkStdGen seed- where seed = 11 -- deterministic RNG with seed--objFnNone :: ObjFnPenaltyState a-objFnNone objs w f v = 0---initParams = Params { weight = initWeight, optStatus = NewIter, objFn = objFnNone, annotations = [] }------------------------- Unpacking-data Annotation = Fix | Vary deriving (Eq, Show)-type Fixed a = [a]-type Varying a = [a]---- make sure this matches circPack and labelPack--- annotations are specified inline here. this is per type, not per value (i.e. all circles have the same fixed parameters). but you could generalize it to per-value by adding or overriding annotations globally after the unpacking--- does not unpack names-unpackObj :: (Floating a, Real a, Show a, Ord a) => Obj' a -> [(a, Annotation)]--- the location of a circle can vary, but not its radius--- unpackObj (C' c) = [(xc' c, Vary), (yc' c, Vary), (r' c, Fix)]-unpackObj (C' c) = [(xc' c, Vary), (yc' c, Vary), (r' c, Vary)]--- unpackObj (S' s) = [(xs' s, Vary), (ys' s, Vary), (side' s, Fix)]-unpackObj (S' s) = [(xs' s, Vary), (ys' s, Vary), (side' s, Vary)]--- the location of a label can vary, but not its width or height (or other attributes)-unpackObj (L' l) = [(xl' l, Vary), (yl' l, Vary), (wl' l, Fix), (hl' l, Fix)]--- the location of a point varies-unpackObj (P' p) = [(xp' p, Vary), (yp' p, Vary)]-unpackObj (A' a) = [(startx' a, Vary), (starty' a, Vary), (endx' a, Vary),- (endy' a, Vary), (thickness' a, Fix)]---- split out because pack needs this annotated list of lists-unpackAnnotate :: (Floating a, Real a, Show a, Ord a) => [Obj' a] -> [[(a, Annotation)]]-unpackAnnotate objs = map unpackObj objs---- TODO check it preserves order-splitFV :: (Floating a, Real a, Show a, Ord a) => [(a, Annotation)] -> (Fixed a, Varying a)-splitFV annotated = foldr chooseList ([], []) annotated- where chooseList :: (a, Annotation) -> (Fixed a, Varying a) -> (Fixed a, Varying a)- chooseList (x, Fix) (f, v) = (x : f, v)- chooseList (x, Vary) (f, v) = (f, x : v)---- optimizer should use this unpack function--- preserves the order of the objects’ parameters--- e.g. unpackSplit [Circ {xc varying, r fixed}, Label {xl varying, h fixed} ] = ( [r, h], [xc, xl] )--- crucially, this does NOT depend on the annotations, it can be used on any list of objects-unpackSplit :: (Floating a, Real a, Show a, Ord a) => [Obj' a] -> (Fixed a, Varying a)-unpackSplit objs = let annotatedList = concat $ unpackAnnotate objs in- splitFV annotatedList------------------------ Packing---- We put `Floating a` into polymorphic objects for the autodiff.--- (Maybe port all objects to polymorphic at some point, but would need to zero the gradient information.)--- Can't use realToFrac here because it will zero the gradient information.--- TODO use DuplicateRecordFields (also use `stack` and fix GLUT error)--need to upgrade GHC and gloss------ TODO comment packing these functions defining conventions-solidArrowPack :: (Real a, Floating a, Show a, Ord a) => SolidArrow -> [a] -> SolidArrow' a-solidArrowPack arr params = SolidArrow' { startx' = sx, starty' = sy, endx' = ex, endy' = ey, thickness' = t,- namesa' = namesa arr, selsa' = selsa arr, colorsa' = colorsa arr }- where (sx, sy, ex, ey, t) = if not $ length params == 5 then error "wrong # params to pack solid arrow"- else (params !! 0, params !! 1, params !! 2, params !! 3, params !! 4)--circPack :: (Real a, Floating a, Show a, Ord a) => Circ -> [a] -> Circ' a-circPack cir params = Circ' { xc' = xc1, yc' = yc1, r' = r1, namec' = namec cir, selc' = selc cir, colorc' = colorc cir }- where (xc1, yc1, r1) = if not $ length params == 3 then error "wrong # params to pack circle"- else (params !! 0, params !! 1, params !! 2)--sqPack :: (Real a, Floating a, Show a, Ord a) => Square -> [a] -> Square' a-sqPack sq params = Square' { xs' = xs1, ys' = ys1, side' = side1, names' = names sq, sels' = sels sq, colors' = colors sq, ang' = ang sq}- where (xs1, ys1, side1) = if not $ length params == 3 then error "wrong # params to pack square"- else (params !! 0, params !! 1, params !! 2)--ptPack :: (Real a, Floating a, Show a, Ord a) => Pt -> [a] -> Pt' a-ptPack pt params = Pt' { xp' = xp1, yp' = yp1, namep' = namep pt, selp' = selp pt }- where (xp1, yp1) = if not $ length params == 2 then error "Wrong # of params to pack point"- else (params !! 0, params !! 1)--labelPack :: (Real a, Floating a, Show a, Ord a) => Label -> [a] -> Label' a-labelPack lab params = Label' { xl' = xl1, yl' = yl1, wl' = wl1, hl' = hl1,- textl' = textl lab, sell' = sell lab, namel' = namel lab }- where (xl1, yl1, wl1, hl1) = if not $ length params == 4 then error "wrong # params to pack label"- else (params !! 0, params !! 1, params !! 2, params !! 3)---- does a right fold on `annotations` to preserve order of output list--- returns remaining (fixed, varying) that were not part of the object--- e.g. yoink [Fixed, Varying, Fixed] [1, 2, 3] [4, 5] = ([1, 4, 2], [3], [5])-yoink :: (Show a) => [Annotation] -> Fixed a -> Varying a -> ([a], Fixed a, Varying a)-yoink annotations fixed varying = --trace ("yoink " ++ (show annotations) ++ (show fixed) ++ (show varying)) $- case annotations of- [] -> ([], fixed, varying)- (Fix : annotations') -> let (params, fixed', varying') = yoink annotations' (tail fixed) varying in- (head fixed : params, fixed', varying')- (Vary : annotations') -> let (params, fixed', varying') = yoink annotations' fixed (tail varying) in- (head varying : params, fixed', varying')---- used inside overall objective fn to turn (fixed, varying) back into a list of objects--- for inner objective fns to operate on--- pack is partially applied with the annotations, which never change--- (the annotations assume the state never changes size or order)-pack :: (Real a, Floating a, Show a, Ord a) => [[Annotation]] -> [Obj] -> Fixed a -> Varying a -> [Obj' a]-pack annotations objs = pack' (zip objs annotations)--pack' :: (Real a, Floating a, Show a, Ord a) => [(Obj, [Annotation])] -> Fixed a -> Varying a -> [Obj' a]-pack' zipped fixed varying =- case zipped of- [] -> []- ((obj, annotations) : zips) -> res : pack' zips fixed' varying' -- preserve order- -- use obj, annotations, fixed, and varying to create the object- -- by yoinking the right params out of f/v in the right order- where (flatParams, fixed', varying') = yoink annotations fixed varying- -- is flatParams in the right order?- res = case obj of- -- pack objects using the names, text params carried from initial state- -- assuming names do not change during opt- C circ -> C' $ circPack circ flatParams- L label -> L' $ labelPack label flatParams- P pt -> P' $ ptPack pt flatParams- S sq -> S' $ sqPack sq flatParams- A ar -> A' $ solidArrowPack ar flatParams---------- Style related functions---- default shapes-defaultSolidArrow, defaultPt, defaultSquare, defaultLabel, defaultCirc, defaultText:: String -> Obj-defaultSolidArrow name = A SolidArrow { startx = 100, starty = 100, endx = 200, endy = 200, thickness = 10,- selsa = False, namesa = name, colorsa = black }-defaultPt name = P Pt { xp = 100, yp = 100, selp = False, namep = name }-defaultSquare name = S Square { xs = 100, ys = 100, side = defaultRad,- sels = False, names = name, colors = black, ang = 0.0}-defaultLabel text = L Label { xl = -100, yl = -100,- wl = textWidth * fromIntegral (length text),- hl = textHeight,- textl = text, sell = False, namel = labelName text }-defaultText text = L Label { xl = -100, yl = -100,- wl = textWidth * fromIntegral (length text),- hl = textHeight,- textl = text, sell = False, namel = text }-defaultCirc name = C Circ { xc = 100, yc = 100, r = defaultRad,- selc = False, namec = name, colorc = black }--initSpec = SA.StySpec { SA.spType = SA.Pt, SA.spId = "", SA.spShape = (SA.NoShape, M.empty), SA.spArgs = [], SA.spShpMap = M.empty}---- ------- Parsing for Old Style Design------ dictOfStys :: [C.SubDecl] -> [C.StyLine] -> M.Map Name [C.StyLine]--- dictOfStys objs stys = foldr (processLine objs) dict stys--- where dict = foldr addObj M.empty objs--- addObj (C.Decl (C.OM (C.Map' name _ _))) = M.insert name []--- addObj (C.Decl (C.OS (C.Set' name _))) = M.insert name []--- addObj (C.Decl (C.OP (C.Pt' name))) = M.insert name []------ -- If there is no spec associated with an obj, we should insert this obj in the dict--- insertSty :: Name -> C.StyLine -> M.Map Name [C.StyLine] -> M.Map Name [C.StyLine]--- insertSty name line dict = case (M.lookup name dict) of--- Nothing -> M.insert name [line] dict--- _ -> M.adjust ([line] ++) name dict------ processLine :: [C.SubDecl] -> C.StyLine -> M.Map Name [C.StyLine] -> M.Map Name [C.StyLine]--- processLine objs s dict =--- case s of--- (C.Shape (C.SubVal v) _) -> insertSty v s dict--- (C.Shape C.Global _) -> M.mapWithKey (\k stys -> s:stys) dict--- (C.Shape (C.SubType t) _) -> M.mapWithKey (\k stys -> s:stys) dict--- otherwise -> error "shape not known"------ -- Find all lines specifying shape--- shapeLines :: [C.StyLine] -> [C.StyLine]--- shapeLines stys = filter isShape $ stys--- where isShape (C.Shape _ _) = True--- isShape _ = False------ -- Given a list of sty settings, find the most specific one--- -- The order from most specific to general: individual -> type -> global--- prioritize :: [C.StyLine] -> C.StyLine--- prioritize stys = stys !! maxIdx--- where prios = map getPrio stys--- Just maxIdx = elemIndex (maximum prios) prios--- getPrio (C.Shape (C.SubVal _) _) = 3--- getPrio (C.Shape C.Global _) = 2--- getPrio (C.Shape (C.SubType _) _) = 1--- Generates an object depending on the style specification------- Parser for the new style design--- -- Given a list of IDs, translate a raw AST of a Style program--- -- to a object-wise record--- getStyDict :: [C.SubDecl] -> SA.StyProg -> M.Map Name SA.StySpec--- getStyDict decls prog = foldl loadObjConfig tConfig oBlk--- where--- ids = getSubTuples decls--- dict = foldl (\m (t, n) ->--- M.insert n (dummySpec { SA.spId = n, SA.spType = t }) m) M.empty ids--- [gBlk, tBlk, oBlk] = getBlocks prog--- gConfig = foldl loadGlobalConfig dict gBlk--- tConfig = foldl loadTypeConfig gConfig tBlk--- -- applyConfig f d = foldl f d prog------ getSubTuples :: [C.SubDecl] -> [(SA.SubType, String)]--- getSubTuples decls = map getType decls--- where--- getType (C.Decl d) = case d of--- C.OS (C.Set' n _) -> (SA.Set, n)--- C.OP (C.Pt' n) -> (SA.Pt, n)--- C.OM (C.Map' n _ _) -> (SA.Map, n)------------ -- NOTE: assuming we process global settings FIRST. All other fields will get wiped out--- loadGlobalConfig :: M.Map Name SA.StySpec -> SA.Block -> M.Map Name SA.StySpec--- loadGlobalConfig dict (SA.GlobalBlock stmts) = M.mapWithKey (\_ oldSpec -> newSpec { SA.spType = SA.spType oldSpec, SA.spId = SA.spId oldSpec}) dict--- where--- newSpec = foldl procStmt dummySpec stmts--- loadGlobalConfig dict _ = dict -- ignore all other blocks------ loadTypeConfig :: M.Map Name SA.StySpec -> SA.Block -> M.Map Name SA.StySpec--- loadTypeConfig dict (SA.TypeBlock typ stmts) = M.mapWithKey (\_ s -> procSpec s) dict--- where--- procSpec s = if SA.spType s == typ then getSpec s else s--- getSpec s = foldl procStmt s stmts--- loadTypeConfig dict _ = dict -- ignore all other blocks------ loadObjConfig :: M.Map Name SA.StySpec -> SA.Block -> M.Map Name SA.StySpec--- loadObjConfig dict (SA.ObjBlock name stmts) = M.mapWithKey (\_ s -> procSpec s) dict--- where--- procSpec s = if SA.spId s == name then getSpec s else s--- getSpec s = foldl procStmt s stmts--- loadObjConfig dict _ = dict -- ignore all other blocks------ procStmt :: SA.StySpec -> SA.Stmt -> SA.StySpec--- procStmt spec (SA.Assign _ (SA.Color c)) = spec { SA.spColor = c }--- procStmt spec (SA.Assign _ (SA.Shape s)) = spec { SA.spShape = s }------ getBlocks :: SA.StyProg -> [[SA.Block]]--- getBlocks p = map (\f -> f p) filters--- where filters = map filter [isGlobalBlock, isTypeBlock, isObjBlock]------ isGlobalBlock, isTypeBlock, isObjBlock :: SA.Block -> Bool--- isGlobalBlock (SA.GlobalBlock _) = True--- isGlobalBlock _ = False------ isTypeBlock (SA.TypeBlock _ _) = True--- isTypeBlock _ = False------ isObjBlock (SA.ObjBlock _ _) = True--- isObjBlock _ = False------- Parser for Style design---- Type aliases for readability in this section-type StyDict = M.Map Name SA.StySpec--- type ObjFn a = M.Map Name (Obj' a) -> a-type ConstrFn a = [Obj' a] -> a-type ObjFn a = [Obj' a] -> a--- A VarMap matches lambda ids in the selector to the actual selected id-type VarMap = M.Map Name Name--getDictAndFns :: (Floating a, Real a, Show a, Ord a) =>- ([C.SubDecl], [C.SubConstr]) -> SA.StyProg- -> (StyDict, [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])-getDictAndFns (decls, constrs) blocks = foldl procBlock (initDict, [], []) blocks- where- res = getSubTuples decls ++ getConstrTuples constrs- ids = map (\(x, y, z) -> (x, y)) res- -- args = map (\(_, _, z) -> z) res- initDict = foldl (\m (t, n, a) ->- M.insert n (initSpec { SA.spId = n, SA.spType = t, SA.spArgs = a }) m) M.empty res- -- applyConfig f d = foldl f d prog--procBlock :: (Floating a, Real a, Show a, Ord a) =>- (StyDict, [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])- -> SA.Block- -> (StyDict, [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])-procBlock (dict, objFns, constrFns) (selectors, stmts) = (newDict, objFns ++ newObjFns, constrFns ++ newConstrFns)- where- select s = M.elems $ M.filter (match s) dict- selectedSpecs :: [[(VarMap, SA.StySpec)]]- selectedSpecs = map- (\s -> let xs = select s- vs = map (allOtherVars . getVarMap s) xs in zip vs xs) selectors- -- TODO: scoping - now every block has access to everyone else- allOtherVars = M.union (M.fromList $ zip k k) where k = M.keys dict- -- Combination of all selected (spec. varmap)- allCombs = filter (\x -> length x == length selectedSpecs) $ cartesianProduct (map (map fst) selectedSpecs)- mergedMaps =- -- let allMaps = map (map fst) allCombs in- -- map M.unions (tr "allMaps: " allMaps)- -- tr "allmaps: " $- map M.unions allCombs- -- Only process assignment statements on matched specs, not the cartesion product of them- updateSpec d (vm, sp) =- let newSpec = foldl (procAssign vm) sp stmts in- M.insert (SA.spId newSpec) newSpec d- newDict = foldl updateSpec dict $ concat selectedSpecs- -- (zip varMaps selected)- genFns f vm = foldl (f vm) [] stmts- newObjFns = concatMap (genFns procObjFn) mergedMaps- newConstrFns = concatMap (genFns procConstrFn) mergedMaps--cartesianProduct = foldr f [[]] where f l a = [ x:xs | x <- l, xs <- a ]---- Returns a map from placeholder ids to actual matched ids-getVarMap :: SA.Selector -> SA.StySpec -> VarMap-getVarMap sel spec = foldl add M.empty patternNamePairs- where- patternNamePairs = zip (SA.selPatterns sel) (SA.spArgs spec)- add d (p, n) = case p of- SA.RawID _ -> d- SA.WildCard i -> M.insert i n d----- Returns true of an object matches the selector-match :: SA.Selector -> SA.StySpec -> Bool-match sel spec = all test (zip args patterns) &&- SA.selTyp sel == SA.spType spec &&- length args == length patterns- where- patterns = SA.selPatterns sel- args = SA.spArgs spec- -- dummies = SA.selIds sel- test (a, p) = case p of- SA.RawID i -> a == i- SA.WildCard _ -> True--procConstrFn :: (Floating a, Real a, Show a, Ord a) =>- VarMap -> [(ConstrFn a, Weight a, [Name])] -> SA.Stmt- -> [(ConstrFn a, Weight a, [Name])]-procConstrFn varMap fns (SA.ConstrFn fname es) =- -- trStr ("New Constraint function: " ++ fname ++ " " ++ (show names)) $- fns ++ [(func, defaultWeight, names)]- where- (func, names) = case M.lookup fname constrFuncDict of- Just f -> (f, map (getIdByExpr varMap) es)- Nothing -> error "procConstrFn: constraint function not known"-procConstrFn varMap fns _ = fns -- TODO: avoid functions--procObjFn :: (Floating a, Real a, Show a, Ord a) =>- VarMap -> [(ObjFn a, Weight a, [Name])] -> SA.Stmt- -> [(ObjFn a, Weight a, [Name])]-procObjFn varMap fns (SA.ObjFn fname es) =- trStr ("New Objective function: " ++ fname ++ " " ++ (show names)) $- fns ++ [(func, defaultWeight, names)]- where- (func, names) = case M.lookup fname objFuncDict of- Just f -> (f, tr "Args: " args)- Nothing -> error "procObjFn: objective function not known"- args = map (getIdByExpr varMap) es-procObjFn varMap fns (SA.Avoid fname es) = fns -- TODO: avoid functions-procObjFn varMap fns _ = fns -- TODO: avoid functions---- TODO: Have a more principled expr look up routine-lookupVarMap s varMap= case M.lookup s varMap of- Just s -> s- Nothing -> (error $ "lookupVarMap: incorrect variable mapping from " ++ s)-getIdByExpr d (SA.Id s) = lookupVarMap s d--- TODO: properly resolve access by doing lookups-getIdByExpr d (SA.BinOp SA.Access (SA.Id i) (SA.Id "label")) = labelName $ lookupVarMap i d-getIdByExpr d (SA.BinOp SA.Access (SA.Id i) (SA.Id "shape")) = lookupVarMap i d-getIdByExpr _ _ = error "getIdByExpr: argument unsupported!"--procAssign :: VarMap -> SA.StySpec -> SA.Stmt -> SA.StySpec-procAssign varMap spec (SA.Assign n (SA.Cons typ stmts)) =- if n == "shape" then spec { SA.spShape = (typ, configs) } -- primary shape- else spec { SA.spShpMap = M.insert n (typ, configs) $ SA.spShpMap spec } -- secondary shapes- where- configs = foldl addSpec M.empty stmts- -- FIXME: this is incorrect, we should resolve the variables earlier- addSpec dict (SA.Assign s e@(SA.Cons SA.NoShape _)) = M.insert s (SA.Id "None") dict- addSpec dict (SA.Assign s e@(SA.Cons SA.Auto _)) = M.insert s (SA.Id "Auto") dict- addSpec dict (SA.Assign s e) = M.insert s (SA.Id (getIdByExpr varMap e)) dict- addSpec _ _ = error "procAssign: only support assignments in constructors!"-procAssign _ spec _ = spec -- TODO: ignoring assignment for all others--getConstrTuples :: [C.SubConstr] -> [(SA.SubType, String, [String])]-getConstrTuples = map getType- where getType c = case c of- C.Intersect a b -> (SA.Intersect, "Intersect" ++ a ++ b, [a, b])- C.NoIntersect a b -> (SA.NoIntersect, "NoIntersect" ++ a ++ b, [a, b])- C.Subset a b -> (SA.Subset, "Subset" ++ a ++ b, [a, b])- C.NoSubset a b -> (SA.NoSubset, "NoSubset" ++ a ++ b, [a, b])- C.PointIn a b -> (SA.PointIn, "PointIn" ++ a ++ b, [a, b])- C.PointNotIn a b -> (SA.PointNotIn, "PointNotIn" ++ a ++ b, [a, b])--getSubTuples :: [C.SubDecl] -> [(SA.SubType, String, [String])]-getSubTuples = map getType- where getType (C.Decl d) = case d of- C.OS (C.Set' n _) -> (SA.Set, n, [n])- C.OP (C.Pt' n) -> (SA.Pt, n, [n])- C.OM (C.Map' n a b) -> (SA.Map, n, [n, a, b])--getAllIds :: ([C.SubDecl], [C.SubConstr]) -> [String]-getAllIds (decls, constrs) = map (\(_, x, _) -> x) $ getSubTuples decls ++ getConstrTuples constrs--shapeAndFn :: (Floating a, Real a, Show a, Ord a) => StyDict -> String -> ([Obj], [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])-shapeAndFn dict name =- case M.lookup name dict of- Nothing -> error ("Cannot find style info for " ++ name)- Just s -> concat3 $ map getShape $ (name, SA.spShape s) : map addPrefix (M.toList $ SA.spShpMap s)- where- concat3 x = (concatMap fst3 x, concatMap snd3 x, concatMap thd3 x)- addPrefix (s, o) = (name ++ "_" ++ s, o)- fst3 (a, _, _) = a- snd3 (_, a, _) = a- thd3 (_, _, a) = a- getShape (n, (SA.Text, config)) = initText n config- getShape (n, (SA.Arrow, config)) = initArrow n config- getShape (n, (SA.Circle, config)) = initCircle n config- getShape (n, (SA.Box, config)) = initSquare n config- getShape (n, (SA.NoShape, _)) = ([], [], [])- getShape (_, (t, _)) = error ("ShapeOf: Unknown shape " ++ show t ++ " for " ++ name)--initText, initArrow, initCircle, initSquare ::- (Floating a, Real a, Show a, Ord a) =>- String -> M.Map String SA.Expr- -> ([Obj], [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])-initText n config = ([defaultText n], [], [])-initArrow n config =- -- ([defaultSolidArrow n, defaultLabel n], [(centerMap, defaultWeight, [n, from, to])], [])- -- ([defaultSolidArrow n], [(centerMap, defaultWeight, [n, from, to])], [])- if lab == "None" then- ([defaultSolidArrow n], [(centerMap, defaultWeight, [n, from, to])], [])- else- ([defaultSolidArrow n, defaultLabel n], [(centerMap, defaultWeight, [n, from, to])], [])- where- from = queryConfig "start" config- to = queryConfig "end" config- lab = queryConfig "label" config-initCircle n config = ([defaultCirc n, defaultLabel n], [], [(penalty . maxSize, defaultWeight, [n]), (penalty . minSize, defaultWeight, [n])])-initSquare n config = ([defaultSquare n, defaultLabel n], [], [(penalty . maxSize, defaultWeight, [n])])--queryConfig key dict = case M.lookup key dict of- Just (SA.Id i) -> i- -- FIXME: get dot access to work for arbitrary input- Just (SA.BinOp SA.Access (SA.Id i) (SA.Id "shape")) -> i- Nothing -> error ("queryConfig: Key " ++ key ++ " does not exist!")--------- Generate objective functions--defaultWeight :: Floating a => a-defaultWeight = 1--defaultRad :: Floating a => a-defaultRad = 100--objFnOnNone :: ObjFnOn a-objFnOnNone _ = 0---- Parameters to change-declSetObjfn :: ObjFnOn a-declSetObjfn = objFnOnNone -- centerCirc--declPtObjfn :: ObjFnOn a-declPtObjfn = objFnOnNone -- centerCirc--declLabelObjfn :: ObjFnOn a-declLabelObjfn = centerLabel -- objFnOnNone--declMapObjfn :: ObjFnOn a-declMapObjfn = centerMap---constrFuncDict :: forall a. (Floating a, Real a, Show a, Ord a) =>- M.Map String (ConstrFn a)-constrFuncDict = M.fromSet mapping allFns- where- allFns = fromList ["sameSizeAs", "smallerThan", "contains", "nonOverlapping", "overlapping", "outsideOf"]- mapping f = case f of- "sameSizeAs" -> penalty . sameSize- "contains" -> penalty . contains- "overlapping" -> penalty . overlapping- "nonOverlapping" -> penalty . nonOverlapping- "outsideOf" -> penalty . outsideOf- "smallerThan" -> penalty . smallerThan -- TODO: should this be an objective?- -- "avoidSubsets" -> penalty . avoidSubsets- _ -> error ("constrFuncDict: unknown function " ++ f)--objFuncDict :: forall a. (Floating a, Real a, Show a, Ord a) => M.Map String (ObjFn a)-objFuncDict = M.fromSet mapping allFns- where- allFns = fromList ["sameX", "sameCenter", "sameHeight", "repel", "onTop", "toLeft", "centerLabel", "outside"]- mapping f = case f of- "centerLabel" -> centerLabel- "toLeft" -> toLeft- "onTop" -> onTop- "sameHeight" -> sameHeight- "sameX" -> (*) 0.2 . sameX- "sameCenter" -> (*) 0.01 . sameCenter- -- "repel" -> penalty . repel- -- "repel" -> (*) 100000000 . repel- -- "repel" -> (*) 9000 . repel- "repel" -> (*) 900000 . repel- -- "repel" -> repe l- -- "repel" -> repel- "outside" -> outside- _ -> error ("objFuncDict: unknown function " ++ f)--genAllObjs :: (Floating a, Real a, Show a, Ord a) =>- ([C.SubDecl], [C.SubConstr]) -> StyDict- -> ([Obj], [(ObjFn a, Weight a, [Name])], [(ConstrFn a, Weight a, [Name])])--- TODO figure out how the types work. also add weights-genAllObjs (decls, constrs) stys = (concat objss, concat objFnss, concat constrFnss)- where- (objss, objFnss, constrFnss) = unzip3 $ map (shapeAndFn stys) $ getAllIds (decls, constrs)---- genObjsAndFns :: (Floating a, Real a, Show a, Ord a) =>--- M.Map String SA.StySpec -> C.SubDecl -> ([Obj], [(M.Map Name (Obj' a) -> a, Weight a)])--- genObjsAndFns stys line@(C.Decl (C.OS (C.Set' sname stype))) = (objs, weightedFns)--- where--- c1 = shapeOf sname stys--- -- TODO proper dimensions for labels--- l1 = defaultLabel sname--- objs = [c1, l1]--- weightedFns = [ (declSetObjfn [sname], defaultWeight),--- (declLabelObjfn [sname, labelName sname], defaultWeight) ]--- genObjsAndFns stys (C.Decl (C.OP (C.Pt' pname))) = (objs, weightedFns)--- where--- p1 = defaultPt pname--- l1 = defaultLabel pname--- objs = [p1, l1]--- weightedFns = [ (declPtObjfn [pname], defaultWeight),--- (declLabelObjfn [pname, labelName pname], defaultWeight) ]--- genObjsAndFns stys (C.Decl (C.OM (C.Map' name from to))) = (objs, weightedFns)--- where--- a = defaultSolidArrow name--- l1 = defaultLabel name--- objs = [a, l1]--- weightedFns = [--- (toLeft [from, to], defaultWeight),--- (sameY [from, to], defaultWeight),--- (declMapObjfn [name, from, to], defaultWeight), -- TODO: a different obj function--- (declLabelObjfn [name, labelName name], defaultWeight)]------- genAllObjsAndFns :: (Floating a, Real a, Show a, Ord a) =>--- [C.SubDecl] -> M.Map String SA.StySpec -> ([Obj], [(M.Map Name (Obj' a) -> a, Weight a)])--- -- TODO figure out how the types work. also add weights--- genAllObjsAndFns decls stys = let (objss, fnss) = unzip $ map (genObjsAndFns stys) decls in--- (concat objss, concat fnss)--dictOf :: (Real a, Floating a, Show a, Ord a) => [Obj' a] -> M.Map Name (Obj' a)-dictOf = foldr addObj M.empty- where addObj o dict = M.insert (getName o) o dict--dictOfObjs :: [Obj] -> M.Map Name Obj-dictOfObjs = foldr addObj M.empty- where addObj o dict = M.insert (getName o) o dict---- constant b/c ambient fn value seems to be 10^4 and constr value seems to reach only 10, 10^2-constrWeight :: Floating a => a-constrWeight = 10 ^ 4--lookupNames :: (Real a, Floating a, Show a, Ord a) => M.Map Name (Obj' a) -> [Name] -> [Obj' a]-lookupNames dict ns = map check res- where- res = map (`M.lookup` dict) ns- check x = case x of- Just x -> x- _ -> error "lookupNames: at least one of the arguments don't exist!"----- TODO should take list of current objects as parameter, and be partially applied with that--- first param: list of parameter annotations for each object in the state--- assumes that the state's SIZE and ORDER never change--- note: CANNOT do dict -> list because that destroys the order-genObjFn :: (Real a, Floating a, Show a, Ord a) =>- [[Annotation]]- -> [(ObjFn a, Weight a, [Name])]- -> [(M.Map Name (Obj' a) -> a, Weight a)]- -> [(ConstrFn a, Weight a, [Name])]- -> [Obj] -> a -> [a] -> [a] -> a-genObjFn annotations objFns ambientObjFns constrObjFns =- \currObjs penaltyWeight fixed varying ->- let newObjs = pack annotations currObjs fixed varying in- let objDict = dictOf newObjs in- sumMap (\(f, w, n) -> w * f (lookupNames objDict n)) objFns- + (tr "ambient fn value: " (sumMap (\(f, w) -> w * f objDict) ambientObjFns))- + (tr "constr fn value: "- (constrWeight * penaltyWeight * sumMap (\(f, w, n) -> w * f (lookupNames objDict n)) constrObjFns))- -- (sumMap (\(f, w) -> w * f objDict) objFns) +- -- (sumMap (\(f, w) -> w * f objDict) ambientObjFns) +- -- (constrWeight * penaltyWeight *- -- sumMap (\(f, w, n) -> w * f (lookupNames objDict n)) constrObjFns)- -- factor out weight application?----- TODO: **must** manually change this constraint if you change the constr function for EP--- needs constr to be violated-constraint :: [C.SubConstr] -> [Obj] -> Bool-constraint constrs = if constraintFlag then \x ->- let res = [consistentSizes constrs x] in and res- else \x -> True---- generate all objects and the overall objective function--- style program is currently unused--- TODO adjust weights of all functions-genInitState :: ([C.SubDecl], [C.SubConstr]) -> SA.StyProg -> State-genInitState (decls, constrs) stys =- -- objects and objectives (without ambient objfns or constrs)- let (dict, userObjFns, userConstrFns) = getDictAndFns (decls, constrs) stys in- let (initObjs, initObjFns, initConstrFns) = genAllObjs (decls, constrs) dict in- let objFns = userObjFns ++ initObjFns in- -- let (initState, objFns) = genAllObjsAndFns decls (getStyDict decls stys) in- -- let objFns = [] in -- TODO removed only for debugging constraints-- -- ambient objectives- -- be careful with how the ambient objectives interact with the per-declaration objectives!- -- e.g. the repel objective conflicts with a subset/intersect constraint -> nonconvergence!- -- let ambientObjFns = [(circlesCenter, defaultWeight)] in- let ambientObjFns = [] in-- -- constraints- -- let constrFns = genConstrFns constrs in- -- let constrFns = [] in- let ambientConstrFns = [] in -- TODO add- let constrObjFns = initConstrFns ++ userConstrFns ++ ambientConstrFns in-- -- resample state w/ constrs. TODO how to deal with `Subset A B` -> `r A < r B`?- -- let boolConstr = \x -> True in // TODO needs to take this as a param- let (initStateConstr, initRng') = sampleConstrainedState initRng initObjs constrs in-- -- unpackAnnotate :: [Obj] -> [ [(Float, Annotation)] ]- let flatObjsAnnotated = unpackAnnotate (addGrads initStateConstr) in- let annotationsCalc = map (map snd) flatObjsAnnotated in -- `map snd` throws away initial floats-- -- overall objective function- let objFnOverall = genObjFn annotationsCalc objFns ambientObjFns constrObjFns in-- State { objs = initStateConstr,- constrs = constrs,- params = initParams { objFn = objFnOverall, annotations = annotationsCalc },- down = False, rng = initRng', autostep = False }----------------- end object / objfn generation--rad :: Floating a => a-rad = 200 -- TODO don't hardcode into constant-clamp1D y = if clampflag then 0 else y--rad1 :: Floating a => a-rad1 = rad-100--rad2 :: Floating a => a-rad2 = rad+50---- Initial state of the world, reading from Substance/Style input-initState :: State-initState = State { objs = objsInit, constrs = [], down = False, rng = initRng, autostep = False, params = initParams }---- divide two integers to obtain a float-divf :: Int -> Int -> Float-divf a b = (fromIntegral a) / (fromIntegral b)--pw2 :: Float-pw2 = picWidth `divf` 2--pw2' :: Floating a => a-pw2' = realToFrac pw2--ph2 :: Float-ph2 = picHeight `divf` 2--ph2' :: Floating a => a-ph2' = realToFrac ph2---- avoid having black and white to ensure the visibility of objects-opacity, cmax, cmin :: Float-opacity = 0.5-cmax = 0.1-cmin = 0.9---- radiusRange, sideRange :: Floating a => (a, a )-widthRange = (-pw2, pw2)-heightRange = (-ph2, ph2)-radiusRange = (20, picWidth `divf` 6)-sideRange = (20, picWidth `divf` 3)-colorRange = (cmin, cmax)--------------- The "Style" layer: render the state of the world.-renderCirc :: Circ -> Picture-renderCirc c = if selected c- then let (r', g', b', a') = rgbaOfColor $ colorc c in- color (makeColor r' g' b' (a' / 2)) $ translate (xc c) (yc c) $- circleSolid (r c)- else color (colorc c) $ translate (xc c) (yc c) $- circleSolid (r c)---- fix to the centering problem of labels, assumeing:--- (1) monospaced font; (2) at least a chracter of max height is in the label string-labelScale, textWidth, textHeight :: Floating a => a-textWidth = 104.76 -- Half of that of the monospaced version-textHeight = 119.05-labelScale = 0.2--label_offset_x, label_offset_y :: String -> Float -> Float-label_offset_x str x = x - (textWidth * labelScale * 0.5 * (fromIntegral (length str)))-label_offset_y str y = y - labelScale * textHeight * 0.5--renderLabel :: Label -> Picture-renderLabel l =- pictures $ [- color scolor $- translate- (label_offset_x (textl l) (xl l))- (label_offset_y (textl l) (yl l)) $- scale labelScale labelScale $- text (textl l)- -- ,- -- line [(x, y), (x + labelScale * w, y), (x + labelScale * w, y + labelScale * h),- -- (x, y + labelScale * h), (x, y)]- ]- where scolor = if selected l then red else light black- w = textWidth * (fromIntegral (length $ textl l))- h = textHeight- x = (label_offset_x (textl l) (xl l))- y = (label_offset_y (textl l) (yl l))---renderPt :: Pt -> Picture-renderPt p = color scalar $ translate (xp p) (yp p)- $ circleSolid ptRadius- where scalar = if selected p then red else black--- renderPt p = color scalar $ translate (xp p) (yp p)--- $ circle ptRadius--- where scalar = if selected p then red else black--- renderPt p = let l1 = line [(-ptRadius, -ptRadius), (ptRadius, ptRadius)]--- l2 = line [(-ptRadius, ptRadius), (ptRadius, -ptRadius)]--- in color scalar $ translate (xp p) (yp p) $ Pictures [l1, l2]--- where scalar = if selected p then red else black--renderSquare :: Square -> Picture-renderSquare s = if selected s- then let (r', g', b', a') = rgbaOfColor $ colors s in- color (makeColor r' g' b' (a' / 2)) $ translate (xs s) (ys s) $- rectangleSolid (side s) (side s)- else color (colors s) $ translate (xs s) (ys s) $- rectangleSolid (side s) (side s)--renderArrow :: SolidArrow -> Picture--- renderArrow sa = color black $ line [(startx sa, starty sa), (endx sa, endy sa)]-renderArrow sa = color scalar $ translate sx sy $ rotate (negate $ toDegree $ argV dir) $ pictures $- map polygon [ head_path, body_path ]- where- scalar = if selected sa then red else black- (sx, sy, ex, ey, t) = (startx sa, starty sa, endx sa, endy sa, thickness sa / 6)- dir = (ex - sx, ey - sy) -- direction the arrow should point to- len = magV dir- body_path = [ (0, 0 + t), (len - 5*t, t),- (len - 5*t, -1*t), (0, -1*t) ]- head_path = [(len - 5*t, 3*t), (len, 0),- (len - 5*t, -3*t)]--toDegree, toRadian :: Floating a => a -> a-toDegree rad = rad * 180 / pi-toRadian deg = deg * pi / 180--renderObj :: Obj -> Picture-renderObj (C circ) = renderCirc circ-renderObj (L label) = renderLabel label-renderObj (P pt) = renderPt pt-renderObj (S sq) = renderSquare sq-renderObj (A ar) = renderArrow ar--isLabel :: Obj -> Bool-isLabel (L l) = True-isLabel _ = False--splitLabels :: [Obj] -> ([Obj], [Obj])-splitLabels objs = (filter isLabel objs, filter (not . isLabel) objs)--picOfState :: State -> Picture-picOfState s =- let (labels, others) = splitLabels (objs s)- in- -- currently not putting labels at the top level because the control is not ready- -- Pictures $ map renderObj others ++ map renderObj labels- Pictures $ map renderObj (objs s)--picOf :: State -> Picture-picOf s = Pictures [picOfState s, objectiveText, constraintText, stateText, paramText, optText]- -- lineXbot, lineXtop, lineYbot, lineYtop]- where -- TODO display constraint instead of hardcoding- -- (picture for bounding box for bound constraints)- -- constraints are currently global params- lineXbot = color red $ Line [(leftb, botb), (rightb, botb)]- lineXtop = color red $ Line [(leftb, topb), (rightb, topb)]- lineYbot = color red $ Line [(leftb, botb), (leftb, topb)]- lineYtop = color red $ Line [(rightb, botb), (rightb, topb)]-- -- TODO generate this text more programmatically- objectiveText = translate xInit yInit $ scale sc sc- $ text objText- constraintText = translate xInit (yInit - yConst) $ scale sc sc- $ text constrText- stateText = let res = if autostep s then "on" else "off" in- translate xInit (yInit - 2 * yConst) $ scale sc sc- $ text ("autostep: " ++ res)- paramText = translate xInit (yInit - 3 * yConst) $ scale sc sc- $ text ("penalty function weight: " ++ show (weight $ params s))- optText = translate xInit (yInit - 4 * yConst) $ scale sc sc- $ text ("optimization status: " ++ (statusTextOf $ optStatus $ params s))- statusTextOf val = case val of- NewIter -> "opt started; new iteration"- UnconstrainedRunning lastState -> "unconstrained running"- UnconstrainedConverged lastState -> "unconstrained converged"- EPConverged -> "EP converged" -- TODO record num iterations- xInit = -pw2+50- yInit = ph2-50- yConst = 30- sc = 0.1--------- Sampling the state subject to a constraint. Currently not used since we are doing unconstrained optimization.---- generate an infinite list of sampled elements--- keep the last generator for the "good" element-genMany :: RandomGen g => g -> (g -> (a, g)) -> [(a, g)]-genMany gen genOne = iterate (\(c, g) -> genOne g) (genOne gen)---- take the first element that satisfies the condition--- not the most efficient impl. also assumes infinite list s.t. head always exists-crop :: RandomGen g => (a -> Bool) -> [(a, g)] -> (a, g)-crop cond xs = --(takeWhile (not . cond) (map fst xs), -- drops gens- head $ dropWhile (\(x, _) -> not $ cond x) xs -- drops while top-level condition true. keeps good's gen---- randomly sample location (for circles and labels) and radius (for circles)-sampleCoord :: RandomGen g => g -> Obj -> (Obj, g)-sampleCoord gen o = let o_loc = setX x' $ setY (clamp1D y') o in- case o_loc of- C circ -> let (r', gen3) = randomR radiusRange gen2- (cr', gen4) = randomR colorRange gen3- (cg', gen5) = randomR colorRange gen4- (cb', gen6) = randomR colorRange gen5- in- (C $ circ { r = r', colorc = makeColor cr' cg' cb' opacity }, gen6)- S sq -> let (side', gen3) = randomR sideRange gen2- (cr', gen4) = randomR colorRange gen3- (cg', gen5) = randomR colorRange gen4- (cb', gen6) = randomR colorRange gen5- in- (S $ sq { side = side', colors = makeColor cr' cg' cb' opacity }, gen6)- L lab -> (o_loc, gen2) -- only sample location- P pt -> (o_loc, gen2)- A a -> (o_loc, gen2) -- TODO-- where (x', gen1) = randomR widthRange gen- (y', gen2) = randomR heightRange gen1---- sample each object independently, threading thru gen-stateMap :: RandomGen g => g -> (g -> a -> (b, g)) -> [a] -> ([b], g)-stateMap gen f [] = ([], gen)-stateMap gen f (x:xs) = let (x', gen') = f gen x in- let (xs', gen'') = stateMap gen' f xs in- (x' : xs', gen'')---- sample a state-genState :: RandomGen g => [Obj] -> g -> ([Obj], g)-genState shapes gen = stateMap gen sampleCoord shapes---- sample entire state at once until constraint is satisfied--- TODO doesn't take into account pairwise constraints or results from objects sampled first, sequentially-sampleConstrainedState :: RandomGen g => g -> [Obj] -> [C.SubConstr] -> ([Obj], g)-sampleConstrainedState gen shapes constrs = (state', gen')- where (state', gen') = crop (constraint constrs) states- states = genMany gen (genState shapes)- -- init state params are ignored; we just need to know what kinds of objects are in it----------------- Handle user input. "handler" is the main function here.--- Whenever the library receives an input event, it calls "handler" with that event--- and the current state of the world to handle it.--ptRadius = 4 -- The size of a point on canvas-bbox = 60 -- TODO put all flags and consts together--- hacky bounding box of label---- -- Find the angle between x-axis and a line passing points, reporting in radians--- findAngle :: Floating a => (a, a) -> (a, a) -> a--- findAngle (x1, y1) (x2, y2) = atan $ (y2 - y1) / (x2 - x1)------ midpoint :: Floating a => (a, a) -> (a, a) -> (a, a) -- mid point--- midpoint (x1, y1) (x2, y2) = ((x1 + x2) / 2, (y1 + y2) / 2)------ dist :: Floating a => (a, a) -> (a, a) -> a -- distance--- dist (x1, y1) (x2, y2) = sqrt ((x1 - x2)^2 + (y1 - y2)^2)------ distsq :: Floating a => (a, a) -> (a, a) -> a -- distance--- distsq (x1, y1) (x2, y2) = (x1 - x2)^2 + (y1 - y2)^2---- Hardcode bbox of label at the center--- TODO properly get bbox; rn text is centered at bottom left-inObj :: (Float, Float) -> Obj -> Bool---- TODO: this is NOT an accurate BBox at all. Good for selection though-inObj (xm, ym) (L o) =- abs (xm - (xl o)) <= 0.1 * (wl o) &&- abs (ym - (yl o)) <= 0.1 * (hl o) -- is label- -- abs (xm - (label_offset_x (textl o) (xl o))) <= 0.25 * (wl o) &&- -- abs (ym - (label_offset_y (textl o) (yl o))) <= 0.25 * (hl o) -- is label-inObj (xm, ym) (C o) = dist (xm, ym) (xc o, yc o) <= r o -- is circle-inObj (xm, ym) (S o) = abs (xm - xs o) <= 0.5 * side o && abs (ym - ys o) <= 0.5 * side o -- is squar e-inObj (xm, ym) (P o) = dist (xm, ym) (xp o, yp o) <= ptRadius -- is Point, where we arbitrarily define the "radius" of a point--- TODO: due to the way Located is defined, we can only drag the starting pt here-inObj (xm, ym) (A a) =- let (sx, sy, ex, ey, t) = (startx a, starty a, endx a, endy a, thickness a)- (x, y) = midpoint (sx, sy) (ex, ey)- len = 0.5 * dist (sx, sy) (ex, ey)- in abs (x - xm) <= len && abs (y - ym) <= t----- check convergence of EP method-epDone :: State -> Bool-epDone s = ((optStatus $ params s) == EPConverged) || ((optStatus $ params s) == NewIter)---- UI so far: pressing and releasing 'r' will re-sample all objects' sizes and positions within some preset range--- if autostep is set, then dragging will move an object while optimization continues--- if autostep is not set, then optimization will only step when 's' is pressed. dragging will move an object while optimization is not happening---- for more on these constructors, see docs: https://hackage.haskell.org/package/gloss-1.10.2.3/docs/Graphics-Gloss-Interface-Pure-Game.html--- pattern matches not fully fuzzed--assume that user only performs one action at once--- (e.g. not left-clicking while stepping the optimization)--- TODO "in object" tests--- prevents user from manipulating objects until EP is done, unless objects are re-sampled--handler :: Event -> State -> State-handler (EventKey (MouseButton LeftButton) Down _ (xm, ym)) s =- if epDone s then s { objs = objsFirstSelected, down = True } else s- -- so that clicking doesn't select all overlapping objects in bbox- -- foldl will reverse the list each time, so a diff obj can be selected- -- foldr will preserve the list order, so objects are stepped consistently- where (objsFirstSelected, _) = foldr (flip $ selectFirstIfContains (xm, ym)) ([], False) (objs s)- selectFirstIfContains (x, y) (xs, alreadySelected) o =- if alreadySelected || (not $ inObj (x, y) o) then (o : xs, alreadySelected)- else (select (setX xm $ setY ym o) : xs, True)--- dragging mouse when down--- if an object is selected, then if the collection of objects with the object moved satisfies the constraint,--- then move the object to mouse position--- TODO there's probably a better way to implement that-handler (EventMotion (xm, ym)) s =- if down s && epDone s then s { objs = map (ifSelectedMoveTo (xm, ym)) (objs s), down = down s } else s- where ifSelectedMoveTo (xm, ym) o = if selected o then setX xm $ setY (clamp1D ym) o else o---- button released, so deselect all objects AND restart the optimization--- keep the annotations and obj fn, otherwise state will be erased-handler (EventKey (MouseButton LeftButton) Up _ _) s =- s { objs = map deselect $ objs s, down = False,- params = (params s) { weight = initWeight, optStatus = NewIter } }---- if you press a key while down, then the handler resets the entire state (then Up will just reset again)-handler (EventKey (Char 'r') Up _ _) s =- s { objs = objs', down = False, rng = rng',- params = (params s) { weight = initWeight, optStatus = NewIter } }- where (objs', rng') = sampleConstrainedState (rng s) (objs s) (constrs s)---- turn autostep on or off (press same button to turn on or off)-handler (EventKey (Char 'a') Up _ _) s = if autostep s then s { autostep = False }- else s { autostep = True }---- pressing 's' (down) while autostep is off will step the optimization once, overriding the step function--- (which doesn't step if autostep is off). this is the same code as the step function but with reverse condition--- if autostep is on, this does nothing--- also overrides EP done: forces a step (might want this to test if there substantial steps left after convergence, e.g. if magnitude of gradient is still large)-handler (EventKey (Char 's') Down _ _) s =- if not $ autostep s then s { objs = objs', params = params' } else s- where (objs', params') = stepObjs (float2Double calcTimestep) (params s) (objs s)---- change the weights in the barrier/penalty method (scale by 10). don't step objects--- only allow the user to change the weights if EP has converged (just make the constraints sharper)--- (doesn't seem to make a difference, though...)--- in that case, start re-running UO with the last EP state as the current (converged) EP state-handler (EventKey (SpecialKey KeyUp) Down _ _) s =- if epDone s then s { params = (params s) { weight = weight', optStatus = status' }} else s- where currWeight = weight (params s)- weight' = currWeight * weightGrowth- status' = UnconstrainedRunning $ EPstate (objs s)--handler (EventKey (SpecialKey KeyDown) Down _ _) s =- if epDone s then s { params = (params s) { weight = weight', optStatus = status' }} else s- where currWeight = weight (params s)- weight' = currWeight / weightGrowth- status' = UnconstrainedRunning $ EPstate (objs s)--handler _ s = s------------- Stepping the state the world via gradient descent.- -- First, miscellaneous helper functions.---- Clamp objects' positions so they don't go offscreen.--- TODO clamp needs to take into account bbox of object-clampX :: Float -> Float-clampX x = if x < -pw2 then -pw2 else if x > pw2 then pw2 else x--clampY :: Float -> Float-clampY y = if y < -ph2 then -ph2 else if y > ph2 then ph2 else y---- minSize :: Float--- minSize = 5---- clampSize :: Float -> Float -- TODO assumes the size is a radius--- clampSize s = if s < minSize then minSize--- else if s > ph2 || s > pw2 then min pw2 ph2 else s---- -- Some debugging functions. @@@--- debugF :: (Show a) => a -> a--- debugF x = if debug then traceShowId x else x--- debugXY x1 x2 y1 y2 = if debug then trace (show x1 ++ " " ++ show x2 ++ " " ++ show y1 ++ " " ++ show y2 ++ "\n") else id------ -- To send output to a file, do ./EXECUTABLE 2> FILE.txt--- tr :: Show a => String -> a -> a--- tr s x = if debug then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order------ trRaw :: Show a => String -> a -> a--- trRaw s x = if debug then trace "---" $ trace s $ trace (show x ++ "\n") x else x-- prints in left to right order------ trStr :: String -> a -> a--- trStr s x = if debug then trace "---" $ trace s x else x -- prints in left to right order------ tr' :: Show a => String -> a -> a--- tr' s x = if debugLineSearch then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order------ tro :: Show a => String -> a -> a--- tro s x = if debugObj then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order--noOverlapPair :: Obj -> Obj -> Bool-noOverlapPair (C c1) (C c) = dist (xc c1, yc c1) (xc c, yc c) > r c1 + r c-noOverlapPair (S s1) (S s2) = dist (xs s1, ys s1) (xs s2, ys s2) > side s1 + side s2--- TODO: factor out this-noOverlapPair (C c) (S s) = dist (xc c, yc c) (xs s, ys s) > (halfDiagonal . side) s + r c-noOverlapPair (S s) (C c) = dist (xs s, ys s) (xc c, yc c) > (halfDiagonal . side) s + r c-noOverlapPair _ _ = True -- TODO, ignores labels---- return true iff satisfied--- TODO deal with labels and more than two objects-noneOverlap :: [Obj] -> Bool-noneOverlap objs = let allPairs = filter (\x -> length x == 2) $ subsequences objs in -- TODO factor out- all id $ map (\[o1, o2] -> noOverlapPair o1 o2) allPairs--- noOverlap (c1 : c : []) = noOverlapPair c1 c--- noOverlap (c1 : c : c3 : _) = noOverlapPair c1 c && noOverlapPair c c3 && noOverlapPair c1 c3 -- TODO--- noOverlap _ _ = True---- allOverlap vs. not noOverlap--they're different!-allOverlap :: [Obj] -> Bool-allOverlap objs = let allPairs = filter (\x -> length x == 2) $ subsequences objs in -- TODO factor out- all id $ map (\[o1, o2] -> not $ noOverlapPair o1 o2) allPairs---- -- used when sampling the inital state, make sure sizes satisfy subset constraints--- subsetSizeDiff :: Floating a => a--- subsetSizeDiff = 10.0---- halfDiagonal :: (Floating a) => a -> a--- halfDiagonal side = 0.5 * dist (0, 0) (side, side)---- TODO: do we want strict subset or loose subset here? Now it is strict-consistentSizes :: [C.SubConstr] -> [Obj] -> Bool-consistentSizes constrs objs = all id $ map (checkSubsetSize dict) constrs- where dict = dictOfObjs objs-checkSubsetSize dict constr@(C.Subset inName outName) =- case (M.lookup inName dict, M.lookup outName dict) of- (Just (C inc), Just (C outc)) ->- -- (r outc) (r inc) > subsetSizeDiff -- TODO: taking this as a parameter?- 0.7 * (r outc) > (r inc)- (Just (S inc), Just (S outc)) -> (side outc) - (side inc) > subsetSizeDiff- -- TODO: this does not scale, general way?- (Just (C c), Just (S s)) -> r c < 0.5 * side s- (Just (S s), Just (C c)) -> (halfDiagonal . side) s < r c- (_, _) -> True-checkSubsetSize _ _ = True----- Type aliases for shorter type signatures.-type TimeInit = Float-type Time = Double-type ObjFn1 a = forall a . (Show a, Ord a, Floating a, Real a) => [a] -> a-type GradFn a = forall a . (Show a, Ord a, Floating a, Real a) => [a] -> [a]-type Constraints = [(Int, (Double, Double))]- -- TODO: convert lists to lists of type-level length, and define an interface for object state (pos, size)- -- also need to check the input length matches obj fn lengths, e.g. in awlinesearch---- old code for bound constraints--- does not project onto an arbitrary set, only intervals--- projCoordInterval :: (Double, Double) -> Double -> Double--- projCoordInterval (lower, upper) x = (sort [lower, upper, x]) !! 1 -- median of the list---- for each element, if there's a constraint on it (by index), project it onto the interval--- lookInAndProj :: Constraints -> (Int, Double) -> [Double] -> [Double]--- lookInAndProj constraints (index, x) acc =--- case (Map.lookup index constraintsMap) of--- Just bounds -> projCoordInterval bounds x : acc--- Nothing -> x : acc--- where constraintsMap = Map.fromList constraints---- don't change the order of elements in the state!! use foldr, not foldl--- projectOnto :: Constraints -> [Double] -> [Double]--- projectOnto constraints state =--- let indexedState = zip [0..] state in--- foldr (lookInAndProj constraints) [] indexedState---------- Step the world by one timestep (provided by the library).--- this function actually ignores the input timestep, because line search calculates the appropriate timestep to use,--- but it's left in, in case we want to debug the line search.--- gloss operates on floats, but the optimization code should be done with doubles, so we--- convert float to double for the input and convert double to float for the output.-step :: TimeInit -> State -> State-step t s = -- if down s then s -- don't step when dragging- if autostep s then s { objs = objs', params = params' } else s- where (objs', params') = stepObjs (float2Double t) (params s) (objs s)---- Utility functions for getting object info (currently unused)-objInfo :: Obj -> [Float]-objInfo o = [getX o, getY o, getSize o] -- TODO deal with labels, also do stuff at type level--stateSize :: Int-stateSize = 3--chunksOf :: Int -> [a] -> [[a]]-chunksOf _ [] = []-chunksOf n l = take n l : chunksOf n (drop n l)--objsInfo :: [a] -> [[a]]-objsInfo = chunksOf stateSize---- from [x,y,s] over all objs, return [x,y] over all-objsCoords :: [a] -> [a]-objsCoords = concatMap (\[x, y, s] -> [x, y]) . objsInfo -- from [x,y,s] over all objs, return [s] over all-objsSizes :: [a] -> [a]-objsSizes = map (\[x, y, s] -> s) . objsInfo--------- convergence criterion for EP--- if you want to use it for UO, needs a different epsilon-epStopCond :: (Floating a, Ord a, Show a) => [a] -> [a] -> a -> a -> Bool-epStopCond x x' fx fx' =- trStr ("EP: \n||x' - x||: " ++ (show $ norm (x -. x'))- ++ "\n|f(x') - f(x)|: " ++ (show $ abs (fx - fx'))) $- (norm (x -. x') <= epStop) || (abs (fx - fx') <= epStop)---- just for unconstrained opt, not EP--- stopEps large bc UO doesn't seem to strongly converge...-optStopCond :: (Floating a, Ord a, Show a) => [a] -> Bool-optStopCond gradEval = trStr ("||gradEval||: " ++ (show $ norm gradEval)- ++ "\nstopEps: " ++ (show stopEps)) $- (norm gradEval <= stopEps)---- unpacks all objects into a big state vector, steps that state, and repacks the new state into the objects--- NOTE: all downstream functions (objective functions, line search, etc.) expect a state in the form of--- a big list of floats with the object parameters grouped together: [x1, y1, size1, ... xn, yn, sizen]---- don't use r2f outside of zeroGrad or addGrad, since it doesn't interact well w/ autodiff-r2f :: (Fractional b, Real a) => a -> b-r2f = realToFrac---- Going from `Floating a` to Float discards the autodiff dual gradient info (I think)-zeroGrad :: (Real a, Floating a, Show a, Ord a) => Obj' a -> Obj-zeroGrad (C' c) = C $ Circ { xc = r2f $ xc' c, yc = r2f $ yc' c, r = r2f $ r' c,- selc = selc' c, namec = namec' c, colorc = colorc' c }-zeroGrad (S' s) = S $ Square { xs = r2f $ xs' s, ys = r2f $ ys' s, side = r2f $ side' s, sels = sels' s, names = names' s, colors = colors' s, ang = ang' s }--zeroGrad (L' l) = L $ Label { xl = r2f $ xl' l, yl = r2f $ yl' l, wl = r2f $ wl' l, hl = r2f $ hl' l,- textl = textl' l, sell = sell' l, namel = namel' l }-zeroGrad (P' p) = P $ Pt { xp = r2f $ xp' p, yp = r2f $ yp' p, selp = selp' p,- namep = namep' p }-zeroGrad (A' a) = A $ SolidArrow { startx = r2f $ startx' a, starty = r2f $ starty' a,- endx = r2f $ endx' a, endy = r2f $ endy' a, thickness = r2f $ thickness' a,- selsa = selsa' a, namesa = namesa' a, colorsa = colorsa' a }--zeroGrads :: (Real a, Floating a, Show a, Ord a) => [Obj' a] -> [Obj]-zeroGrads = map zeroGrad---- Add the grad info by generalizing Obj (on Floats) to polymorphic objects (for autodiff to use)-addGrad :: (Real a, Floating a, Show a, Ord a) => Obj -> Obj' a-addGrad (C c) = C' $ Circ' { xc' = r2f $ xc c, yc' = r2f $ yc c, r' = r2f $ r c,- selc' = selc c, namec' = namec c, colorc' = colorc c }-addGrad (S s) = S' $ Square' { xs' = r2f $ xs s, ys' = r2f $ ys s, side' = r2f $ side s, sels' = sels s,- names' = names s, colors' = colors s, ang' = ang s }-addGrad (L l) = L' $ Label' { xl' = r2f $ xl l, yl' = r2f $ yl l, wl' = r2f $ wl l, hl' = r2f $ hl l,- textl' = textl l, sell' = sell l, namel' = namel l }-addGrad (P p) = P' $ Pt' { xp' = r2f $ xp p, yp' = r2f $ yp p, selp' = selp p,- namep' = namep p }-addGrad (A a) = A' $ SolidArrow' { startx' = r2f $ startx a, starty' = r2f $ starty a,- endx' = r2f $ endx a, endy' = r2f $ endy a, thickness' = r2f $ thickness a,- selsa' = selsa a, namesa' = namesa a, colorsa' = colorsa a }---addGrads :: (Real a, Floating a, Show a, Ord a) => [Obj] -> [Obj' a]-addGrads = map addGrad---- implements exterior point algo as described on page 6 here:--- https://www.me.utexas.edu/~jensen/ORMM/supplements/units/nlp_methods/const_opt.pdf--- the initial state (WRT violating constraints), initial weight, params, constraint normalization, etc.--- have all been initialized or set earlier-stepObjs :: (Real a, Floating a, Show a, Ord a) => a -> Params -> [Obj] -> ([Obj], Params)-stepObjs t sParams objs =- let (epWeight, epStatus) = (weight sParams, optStatus sParams) in- case epStatus of-- -- start the outer EP optimization and the inner unconstrained optimization, recording initial EPstate- NewIter -> let status' = UnconstrainedRunning $ EPstate objs in- (objs', sParams { weight = initWeight, optStatus = status'} )-- -- check *weak* convergence of inner unconstrained opt.- -- if UO converged, set opt state to converged and update UO state (NOT EP state)- -- if not, keep running UO (inner state implicitly stored)- -- note convergence checks are only on the varying part of the state- UnconstrainedRunning lastEPstate -> -- doesn't use last EP state- -- let unconstrConverged = optStopCond gradEval in- let unconstrConverged = epStopCond stateVarying stateVarying'- (objFnApplied stateVarying) (objFnApplied stateVarying') in- if unconstrConverged then- let status' = UnconstrainedConverged lastEPstate in -- update UO state only!- (objs', sParams { optStatus = status'}) -- note objs' (UO converged), not objs- else (objs', sParams) -- update UO state but not EP state; UO still running-- -- check EP convergence. if converged then stop, else increase weight, update states, and run UO again- -- TODO some trickiness about whether unconstrained-converged has updated the correct state- -- and whether i should check WRT the updated state or not- UnconstrainedConverged (EPstate lastEPstate) ->- let (_, epStateVarying) = tupMap (map float2Double) $ unpackSplit- $ addGrads lastEPstate in -- TODO factor out- let epConverged = epStopCond epStateVarying stateVarying -- stateV is last state for converged UO- (objFnApplied epStateVarying) (objFnApplied stateVarying) in- if epConverged then- let status' = EPConverged in -- no more EP state- (objs, sParams { optStatus = status'}) -- do not update UO state- -- update EP state: to be the converged state from the most recent UO- else let status' = UnconstrainedRunning $ EPstate objs in -- increase weight- (objs, sParams { weight = weightGrowth * epWeight, optStatus = status' })-- -- done; don't update obj state or params; user can now manipulate- EPConverged -> (objs, sParams)-- -- TODO: implement EPConvergedOverride (for when the magnitude of the gradient is still large)-- -- TODO factor out--only unconstrainedRunning needs to run stepObjective, but EPconverged needs objfn- where (fixed, stateVarying) = tupMap (map float2Double) $ unpackSplit $ addGrads objs- -- realToFrac used because `t` output is a Float? I don't really know why this works- (stateVarying', objFnApplied, gradEval) = stepWithObjective objs fixed sParams- (realToFrac t) stateVarying- -- re-pack each object's state list into object- objs' = zeroGrads $ pack (annotations sParams) objs fixed stateVarying'---- Given the time, state, and evaluated gradient (or other search direction) at the point,--- return the new state. Note that the time is treated as `Floating a` (which is internally a Double)--- not gloss's `Float`-stepT :: Floating a => a -> a -> a -> a-stepT dt x dfdx = x - dt * dfdx---- Calculates the new state by calculating the directional derivatives (via autodiff)--- and timestep (via line search), then using them to step the current state.--- Also partially applies the objective function.-stepWithObjective :: (RealFloat a, Real a, Floating a, Ord a, Show a) =>- [Obj] -> [a] -> Params -> a -> [a] -> ([a], [a] -> a, [a])-stepWithObjective objs fixed stateParams t state = (steppedState, objFnApplied, gradEval)- where (t', gradEval) = timeAndGrad objFnApplied t state- -- get timestep via line search, and evaluated gradient at the state- -- step each parameter of the state with the time and gradient- -- gradEval :: [Double]; gradEval = [dfdx1, dfdy1, dfdsize1, ...]- steppedState = let state' = map (\(v, dfdv) -> stepT t' v dfdv) (zip state gradEval) in- trStr ("||x' - x||: " ++ (show $ norm (state -. state'))- ++ "\n|f(x') - f(x)|: " ++- (show $ abs (objFnApplied state - objFnApplied state')))- state'- objFnApplied :: ObjFn1 a -- i'm not clear on why realToFrac is needed here either- -- since everything should already be polymorphic- -- here, objFn is a function that gets the objective function from stateParams- -- note that the objective function is partially applied w/ current list of objects- objFnApplied = (objFn stateParams) objs (realToFrac cWeight) (map realToFrac fixed)- cWeight = weight stateParams---- a version of grad with a clearer type signature-appGrad :: (Show a, Ord a, Floating a, Real a) =>- (forall a . (Show a, Ord a, Floating a, Real a) => [a] -> a) -> [a] -> [a]-appGrad f l = grad f l--nanSub :: (RealFloat a, Floating a) => a-nanSub = 0--removeNaN' :: (RealFloat a, Floating a) => a -> a-removeNaN' x = if isNaN x then nanSub else x--removeNaN :: (RealFloat a, Floating a) => [a] -> [a]-removeNaN = map removeNaN'--removeInf' :: (RealFloat a, Floating a) => a -> a-removeInf' x = if isInfinity x then bignum else if isNegInfinity x then (-bignum) else x- where bignum = 10**10--removeInf :: (RealFloat a, Floating a) => [a] -> [a]-removeInf = map removeInf'--tupMap :: (a -> b) -> (a, a) -> (b, b)-tupMap f (a, b) = (f a, f b)---- ----- Lists-as-vectors utility functions, TODO split out of file------ -- define operator precedence: higher precedence = evaluated earlier--- infixl 6 +., -.--- infixl 7 *. -- .*, /.------ -- assumes lists are of the same length--- dotL :: Floating a => [a] -> [a] -> a--- dotL u v = if not $ length u == length v--- then error $ "can't dot-prod different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v)--- else sum $ zipWith (*) u v------ (+.) :: Floating a => [a] -> [a] -> [a] -- add two vectors--- (+.) u v = if not $ length u == length v--- then error $ "can't add different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v)--- else zipWith (+) u v------ (-.) :: Floating a => [a] -> [a] -> [a] -- subtract two vectors--- (-.) u v = if not $ length u == length v--- then error $ "can't subtract different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v)--- else zipWith (-) u v------ negL :: Floating a => [a] -> [a]--- negL = map negate------ (*.) :: Floating a => a -> [a] -> [a] -- multiply by a constant--- (*.) c v = map ((*) c) v------ norm :: Floating a => [a] -> a--- norm = sqrt . sum . map (^ 2)------ normsq :: Floating a => [a] -> a--- normsq = sum . map (^ 2)------ normalize :: Floating a => [a] -> [a]--- normalize v = (1 / norm v) *. v----------- Given the objective function, gradient function, timestep, and current state,--- return the timestep (found via line search) and evaluated gradient at the current state.--- TODO change stepWithGradFn(s) to use this fn and its type--- note: continue to use floats throughout the code, since gloss uses floats--- the autodiff library requires that objective functions be polymorphic with Floating a--- M-^ = delete indentation-timeAndGrad :: (Show b, Ord b, RealFloat b, Floating b, Real b) => ObjFn1 a -> b -> [b] -> (b, [b])-timeAndGrad f t state = tr "timeAndGrad: " (timestep, gradEval)- where gradF :: GradFn a- gradF = appGrad f- gradEval = gradF state- -- Use line search to find a good timestep.- -- Redo if it's NaN, defaulting to 0 if all NaNs. TODO- descentDir = negL gradEval- -- timestep :: Floating c => c- timestep = if not linesearch then t else -- use a fixed timestep for debugging- let resT = awLineSearch f duf descentDir state in- if isNaN resT then tr "returned timestep is NaN" nanSub else resT- -- directional derivative at u, where u is the negated gradient in awLineSearch- -- descent direction need not have unit norm- -- we could also use a different descent direction if desired- duf :: (Show a, Ord a, Floating a, Real a) => [a] -> [a] -> a- duf u x = gradF x `dotL` u---- Parameters for Armijo-Wolfe line search--- NOTE: must maintain 0 < c1 < c2 < 1-c1 :: Floating a => a-c1 = 0.4 -- for Armijo, corresponds to alpha in backtracking line search (see below for explanation)--- smaller c1 = shallower slope = less of a decrease in fn value needed = easier to satisfy--- turn Armijo off: c1 = 0--c2 :: Floating a => a-c2 = 0.2 -- for Wolfe, is the factor decrease needed in derivative value--- new directional derivative value / old DD value <= c2--- smaller c2 = smaller new derivative value = harder to satisfy--- turn Wolfe off: c1 = 1 (basically backatracking line search onlyl--infinity :: Floating a => a-infinity = 1/0 -- x/0 == Infinity for any x > 0 (x = 0 -> Nan, x < 0 -> -Infinity)--- all numbers are smaller than infinity except infinity, to which it's equal--negInfinity :: Floating a => a-negInfinity = -infinity--isInfinity x = (x == infinity)-isNegInfinity x = (x == negInfinity)---- Implements Armijo-Wolfe line search as specified in Keenan's notes, converges on nonconvex fns as well--- based off Lewis & Overton, "Nonsmooth optimization via quasi-Newton methods", page TODO--- duf = D_u(f), the directional derivative of f at descent direction u--- D_u(x) = <gradF(x), u>. If u = -gradF(x) (as it is here), then D_u(x) = -||gradF(x)||^2--- TODO summarize algorithm--- TODO what happens if there are NaNs in awLineSearch? or infinities-awLineSearch :: (Floating b, Ord b, Show b, Real b) => ObjFn1 a -> ObjFn2 a -> [b] -> [b] -> b-awLineSearch f duf_noU descentDir x0 =- -- results after a&w are satisfied are junk and can be discarded- -- drop while a&w are not satisfied OR the interval is large enough- let (af, bf, tf) = head $ dropWhile intervalOK_or_notArmijoAndWolfe- $ iterate update (a0, b0, t0) in tf- where (a0, b0, t0) = (0, infinity, 1)- duf = duf_noU descentDir- update (a, b, t) =- let (a', b', sat) = if not $ armijo t then tr' "not armijo" (a, t, False)- else if not $ weakWolfe t then tr' "not wolfe" (t, b, False)- -- remember to change both wolfes- else (a, b, True) in- if sat then (a, b, t) -- if armijo and wolfe, then we use (a, b, t) as-is- else if b' < infinity then tr' "b' < infinity" (a', b', (a' + b') / 2)- else tr' "b' = infinity" (a', b', 2 * a')- intervalOK_or_notArmijoAndWolfe (a, b, t) = not $- if armijo t && weakWolfe t then -- takes precedence- tr ("stop: both sat. |-gradf(x0)| = " ++ show (norm descentDir)) True- else if abs (b - a) < minInterval then- tr ("stop: interval too small. |-gradf(x0)| = " ++ show (norm descentDir)) True- else False -- could be shorter; long for debugging purposes- armijo t = (f ((tr' "** x0" x0) +. t *. (tr' "descentDir" descentDir))) <= ((tr' "fAtX0"fAtx0) + c1 * t * (tr' "dufAtX0" dufAtx0))- strongWolfe t = abs (duf (x0 +. t *. descentDir)) <= c2 * abs dufAtx0- weakWolfe t = duf_x_tu >= (c2 * dufAtx0) -- split up for debugging purposes- where duf_x_tu = tr' "Duf(x + tu)" (duf (x0 +. t' *. descentDir'))- t' = tr' "t" t- descentDir' = descentDir --tr' "descentDir" descentDir- dufAtx0 = duf x0 -- cache some results, can cache more if needed- fAtx0 =f x0 -- TODO debug why NaN. even using removeNaN' didn't help- minInterval = if intervalMin then 10 ** (-10) else 0- -- stop if the interval gets too small; might not terminate-------------------------- ### frequently-changed params for debugging--objsInit = []---- Flags for debugging the surrounding functions.-clampflag = False--- debug = True--- debug = False--- debugLineSearch = False--- debugObj = False -- turn on/off output in obj fn or constraint-constraintFlag = False-objFnOn = True -- turns obj function on or off in exterior pt method (for debugging constraints only)-constraintFnOn = True -- TODO need to implement constraint fn synthesis--type ObjFnPenalty a = forall a . (Show a, Floating a, Ord a, Real a) => a -> [a] -> [a] -> a--- needs to be partially applied with the current list of objects--- this type is only for the TOP-LEVEL synthesized objective function, not for any of the ones that people write-type ObjFnPenaltyState a = forall a . (Show a, Floating a, Ord a, Real a) => [Obj] -> a -> [a] -> [a] -> a---- TODO should use objFn as a parameter-objFnPenalty :: ObjFnPenalty a-objFnPenalty weight = combineObjfns objFnUnconstrained weight- where objFnUnconstrained :: Floating a => ObjFn2 a- -- objFnUnconstrained = centerObjs -- centerAndRepel- objFnUnconstrained = centerAndRepel---- if the list of constraints is empty, it behaves as unconstrained optimization-boundConstraints :: Constraints-boundConstraints = [] -- first_two_objs_box--weightGrowth :: Floating a => a -- for EP weight-weightGrowth = 10--epStop :: Floating a => a -- for EP diff-epStop = 10 ** (-3)--- epStop = 60 ** (-3)--- epStop = 0.01--- epStop = 0.1---- for use in barrier/penalty method (interior/exterior point method)--- seems if the point starts in interior + weight starts v small and increases, then it converges--- not quite... if the weight is too small then the constraint will be violated-initWeight :: Floating a => a-initWeight = 10 ** (-5)--- initWeight = 10 ** (-3)---stopEps :: Floating a => a-stopEps = 10 ** (-1)-------------- Various constants and helper functions related to objective functions---- epsd :: Floating a => a -- to prevent 1/0 (infinity). put it in the denominator--- epsd = 10 ** (-10)--objText = "objective: center all sets; center all labels in set"-constrText = "constraint: satisfy constraints specified in Substance program"---- separates fixed parameters (here, size) from varying parameters (here, location)--- ObjFn2 has two parameters, ObjFn1 has one (partially applied)-type ObjFn2 a = forall a . (Show a, Ord a, Floating a, Real a) => [a] -> [a] -> a--linesearch = True -- TODO move these parameters back-intervalMin = True -- true = force linesearch halt if interval gets too small; false = no forced halt--sumMap :: Floating b => (a -> b) -> [a] -> b -- common pattern in objective functions-sumMap f l = sum $ map f l---------------- Sample bound constraints---- TODO test bound constraints with EP, keep separate and formally build in if it doesn't work--- TODO add more constraints for testing---- x-coord of first object's center in [-300,-200], y-coord of first object's center in [0, 200]-first_two_objs_box :: Constraints-first_two_objs_box = [(0, (-300, -100)), (1, (0, 200)), (4, (100, 300)), (5, (-100, -400))]---------------- Objective functions---- simple test function-minx1 :: ObjFn2 a -- timestep t-minx1 _ xs = if length xs == 0 then error "minx1 empty list" else (head xs)^2---- only center the first object (for debugging). NOTE: need to pass in parameters in the right order-centerObjNoSqrt :: ObjFn2 a-centerObjNoSqrt _ (x1 : y1 : _) = x1^2 + y1^2 -- sum $---- center both objects without sqrt-centerObjsNoSqrt :: ObjFn2 a-centerObjsNoSqrt _ = sumMap (^2)--centerx1Sqrt :: ObjFn2 a -- discontinuous, timestep = 100 * t. autodiff behaves differently for this vs abs-centerx1Sqrt _ (x1 : _) = sqrt $ x1^2---- lot of "interval too small"s happening with the objfns on lists now-centerObjs :: ObjFn2 a -- with sqrt-centerObjs fixed = sqrt . (centerObjsNoSqrt fixed)---- Repel two objects-repel2 :: ObjFn2 a-repel2 _ [x1, y1, x2, y2] = 1 / ((x1 - x2)^2 + (y1 - y2)^2 + epsd)---- pairwise repel on a list of objects (by distance b/t their centers)-repelCenter :: ObjFn2 a-repelCenter _ locs = sumMap (\x -> 1 / (x + epsd)) denoms- where denoms = map diffSq allPairs- diffSq [[x1, y1], [x2, y2]] = (x1 - x2)^2 + (y1 - y2)^2- allPairs = filter (\x -> length x == 2) $ subsequences objs- -- TODO implement more efficient version. also, subseq only returns *unique* subseqs- objs = chunksOf 2 locs---- does not deal with labels-centerAndRepel :: ObjFn2 a -- timestep t-centerAndRepel fixed varying = centerObjsNoSqrt fixed varying + weight * repelCenter fixed varying- where weight = 10 ** (9.8) -- TODO calculate this weight as a function of radii and bbox---- pairwise repel on a list of objects (by distance b/t their centers)--- TODO: version of above function that separates fixed parameters (size) from varying parameters (location)--- assuming 1 size for each two locs, and s1 corresponds to x1, y1 (and so on)-repelDist :: ObjFn2 a-repelDist sizes locs = sumMap (\x -> 1 / (x + epsd)) denoms- where denoms = map diffSq allPairs- diffSq [[x1, y1, s1], [x2, y2, s2]] = (x1 - x2)^2 + (y1 - y2)^2 - s1 - s2- allPairs = filter (\x -> length x == 2) $ subsequences objs- objs = zipWith (++) locPairs sizes'- (sizes', locPairs) = (map (\x -> [x]) sizes, chunksOf 2 locs)---- attempts to account for the radii of the objects--- currently, they repel each other "too much"--want them to be as centered as possible--- not sure whether to use sqrt or not--- try multiple objects?-centerAndRepel_dist :: ObjFn2 a-centerAndRepel_dist fixed varying = centerObjsNoSqrt fixed varying + weight * (repelDist fixed varying)- where weight = 10 ** 10---------doNothing :: ObjFn2 a -- for debugging-doNothing _ _ = 0--nonDifferentiable :: ObjFn2 a-nonDifferentiable sizes locs = let q = head locs in- -- max q 0- abs q -- actually works fine with the line search---- TODO these need separate pack/unpack functions because they change the sizes. these don't currently work-grow2 :: ObjFn2 a-grow2 _ [_, _, s1, _, _, s2] = 1 / (s1 + epsd) + 1 / (s2 + epsd)--grow :: ObjFn2 a-grow _ varying = sumMap (\x -> 1 / (x + epsd)) $ varying---- TODO this needs to use the set size info. hardcode radii for now--- TODO to use "min rad rad1" we need to add "Ord a" to the type signatures everywhere--- we want the distance between the sets to be <overlap> less than having them just touch--- this isn't working? and isn't resampling?--- also i'm getting interval shrinking problems just with this function (using 'distance' only)-setsIntersect2 :: ObjFn2 a-setsIntersect2 sizes [x1, y1, x2, y2] = (dist (x1, y1) (x2, y2) - overlap)^2- where overlap = rad + rad1 - 0.5 * rad1 -- should be "min rad rad1"-------- Objective function to place a label either inside of or right outside of a set--eps' :: Floating a => a-eps' = 60 -- why is this 100??---- two parabolas, one at f(d) = d^2 and one at f(d) = (d-c)^2, intersecting at c/2--- (i could try making the first one bigger and solving for the new intersection pt if i want the threshold--- to be greater than (r + margin)/2---- note: whenever an objective function has a partial derivative that might be fractional,--- and vary in the denominator, need to add epsilon to denominator to avoid 1/0, or avoid it altogether--- e.g. f(x) = sqrt(x) -> f'(x) = 1/(2sqrt(x))--- in the first branch, we square the distance, because the objective there is to minimize the distance (resulting in 1/0).--- in the second branch, the objective is to keep the distance at (r_set + margin), not at 0--so there’s no NaN in the denominator-centerOrRadParabola2 :: Bool -> ObjFn2 a-centerOrRadParabola2 inSet [r_set, _] [x1, y1, x2, y2] =- if dsq <= r_set^2 then dsq- else (if inSet then dsq else coeff * (d - const)^2) -- false -> can lay it outside as well- where d = dist (x1, y1) (x2, y2) -- + epsd- dsq = distsq (x1, y1) (x2, y2) -- + epsd- coeff = r_set^2 / (r_set - const)^2 -- chosen s.t. parabolas intersect at r- const = r_set + margin -- second parabola's zero- margin = if r_set <= 30 then 30 else 60 -- distance from edge of set (as a fn of r)- -- we want r to be close to r_set+margin, otherwise if r is small it converges slowly?---- NOTE: assumes that object and label are exactly contiguous in list: sizes of [o1, l1, o2, l2...]--- and locs: [x_o1, y_o1, x_l1, y_l1, x_o2, y_o2, x_l2, y_l2...]--- TODO abstract out repelDist / labelSum pattern-labelSum :: Bool -> ObjFn2 a-labelSum inSet objLabelSizes objLabelLocs =- let objLabelSizes' = chunksOf 2 objLabelSizes in- let objLabelLocs' = chunksOf 4 objLabelLocs in- sumMap (\(sizes, locs) -> centerOrRadParabola2 inSet sizes locs) (zip objLabelSizes' objLabelLocs')------------ TODO: label-only obj fns don't work out-of-the-box with set-only obj fns since they do unpacking differently---- Start composing set-wise functions (centerAndRepel) with set-label functions (labelSum)--- Sets repel each other, labels repel each other, and sets are labeled--- TODO non-label sets should repel those labels--- TODO resample initial state s.t. labels start inside the set (the centerOrRad is mostly useful if there are other objects inside the set that might repel the label)--- TODO abstract out the unpacking functions here and factor out the weights-centerRepelLabel :: ObjFn2 a-centerRepelLabel olSizes olLocs =- centerAndRepel oSizes oLocs + weight * repelCenter lSizes lLocs + labelSum inSet olSizes olLocs- where (oSizes, lSizes) = (map fst zippedSizes, map snd zippedSizes)- zippedSizes = map (\[obj, lab] -> (obj, lab)) $ chunksOf 2 olSizes- (oLocs, lLocs) = (concatMap fst zippedLocs, concatMap snd zippedLocs)- zippedLocs = map (\[xo, yo, xl, yl] -> ([xo, yo], [xl, yl])) $ chunksOf 4 olLocs- weight = 10 ** 6- inSet = True -- label only in set vs. in or at radius------------------- Exterior point method functions--- Given an objective function and a list of constraints (phrased in terms of violations on a list of floats),--- combines them using the penalty method (parametrized by a constraint weight over the sum of the constraints,--- & individual normalizing weights on each constraint). Returns the corresponding unconstrained objective fn,--- for use in unconstrained opt with line search.---- PAIRWISE constraint functions that return the magnitude of violation--- same type as ObjFn2; more general than PairConstrV-type StateConstrV a = forall a . (Floating a, Ord a, Show a) => [a] -> [a] -> a--- type PairConstrV a = forall a . (Floating a, Ord a, Show a) => [[a]] -> a -- takes pairs of "packed" objs---- noConstraint :: PairConstrV a--- noConstraint _ = 0------ -- To convert your inequality constraint into a violation to be penalized:--- -- it needs to be in the form "c < 0" and c is the violation penalized if > 0--- -- so e.g. if you want "x < -100" then you would convert it to "x + 100 < 0" with c = x + 100--- -- if you want "f x > -100" then you would convert it to "-(f x + 100) < 0" with c = -(f x + 100)"------ -- all sets must pairwise-strict-intersect--- -- plus an offset so they overlap by a visible amount (perhaps this should be an optimization parameter?)--- looseIntersect :: PairConstrV a--- looseIntersect [[x1, y1, s1], [x2, y2, s2]] = let offset = 10 in--- -- if s1 + s2 < offset then error "radii too small" --TODO: make it const--- -- else--- dist (x1, y1) (x2, y2) - (s1 + s2 - offset)------ -- the energy actually increases so it always settles around the offset--- -- that's because i am centering all of them--test w/objective off--- -- TODO flatten energy afterward, or get it to be *far* from the other set--- -- offset so the sets differ by a visible amount--- noSubset :: PairConstrV a--- noSubset [[x1, y1, s1], [x2, y2, s2]] = let offset = 10 in -- max/min dealing with s1 > s2 or s2 < s1--- -(dist (x1, y1) (x2, y2)) + max s2 s1 - min s2 s1 + offset------ -- the first set is the subset of the second, and thus smaller than the second in size.--- -- TODO: test for equal sets--- -- TODO: for two primitives we have 4 functions, which is not sustainable. NOT NEEDED, remove them.--- strictSubset :: PairConstrV a--- strictSubset [[x1, y1, s1], [x2, y2, s2]] = dist (x1, y1) (x2, y2) - (s2 - s1)------ -- exterior point method constraint: no intersection (meaning also no subset)--- noIntersectExt :: PairConstrV a--- noIntersectExt [[x1, y1, s1], [x2, y2, s2]] = -(dist (x1, y1) (x2, y2)) + s1 + s2 + offset where offset = 10------ pointInExt :: PairConstrV a--- pointInExt [[x1, y1], [x2, y2, r]] = dist (x1, y1) (x2, y2) - 0.5 * r------ pointNotInExt :: PairConstrV a--- pointNotInExt [[x1, y1], [x2, y2, r]] = - dist (x1, y1) (x2, y2) + r------ -- exterior point method: penalty function--- penalty :: (Ord a, Floating a, Show a) => a -> a--- penalty x = (max x 0) ^ q -- weights should get progressively larger in cr_dist--- where q = 2 -- also, may need to sample OUTSIDE feasible set--- -- where q = 3 -- also, may need to sample OUTSIDE feasible set---- for each pair, for each constraint on that pair, compose w/ penalty function and sum--- TODO add vector of normalization constants for each constraint-pairToPenalties :: PairConstrV a-pairToPenalties pair = sum $ map (\((f, w), p) -> w * (penalty $ f p)) $ zip pairConstrVs (repeat pair)---- sum penalized violations of each constraint on the whole state-stateConstrsToObjfn :: ObjFn2 a-stateConstrsToObjfn fixed varying = sum $ map (\((f, w), (fix, vary)) -> w * (penalty $ f fix vary))- $ zip stateConstrVs (repeat (fixed, varying))---- the overall penalty function is the sum m (unweighted)--- generate all unique pairs of objs and sum the penalized violation on each pair-pairConstrsToObjfn :: ObjFn2 a-pairConstrsToObjfn sizes locs = sumMap pairToPenalties allPairs- where -- generates all *unique* pairs (does not generate e.g. (o1, o2) and (o2, o1))- allPairs = filter (\x -> length x == 2) $ subsequences objs- objs = zipWith (++) locPairs sizes'- (sizes', locPairs) = (map (\x -> [x]) sizes, chunksOf 2 locs)---- add the obj fn value to all penalized violations of constraints--- note that a high weight may result in an "ill-conditioned hessian" with high differences b/t eigenvalues--- with which the line search and stopping conditions may have trouble--- https://www.researchgate.net/post/What_is_stopping_criteria_of_any_optimization_algorithm-combineObjfns :: ObjFn2 a -> ObjFnPenalty a-combineObjfns objfn weight fixed varying = -- input objfn is unconstrained- (if objFnOn then tro "obj val" $ objWeight * objfn fixed varying else 0)- + (if constraintFnOn then tro "penalty val" $- weight * (pairConstrsToObjfn fixed varying + stateConstrsToObjfn fixed varying)- else 0)- where objWeight = 1---- constraint functions that act on the entire state--- this one just acts on the first object and ignores the fixed params-firstObjInBbox :: (Floating a, Ord a, Show a) => (a, a, a, a) -> [([a] -> [a] -> a, a)]-firstObjInBbox (l, r, b, t) = [(leftBound, 1), (rightBound, 1), (botBound, 1), (topBound, 1)]- where leftBound fixed (x1 : _ : _) = -(x1 - l)- leftBound _ _ = error "not enough floats in state to apply constr function firstObjInBbox"- rightBound fixed (x1 : _ : _) = x1 - r- botBound fixed (_ : y1 : _) = -(y1 - b)- topBound fixed (_ : y1 : _) = y1 - t--stateConstrVs :: (Floating a, Ord a, Show a) => [([a] -> [a] -> a, a)] -- constr, constr weight-stateConstrVs = -- firstObjInBbox (leftb, rightb, botb, topb)- -- ++ firstObjInBbox (-pw2', pw2', -ph2', ph2') -- first object in viewport, TODO for all objs- [] -- TODO add more---- Parameter to modify (TODO move it to other section)--- [PairConstrV a] is not allowed b/c impredicative types-pairConstrVs :: (Floating a, Ord a, Show a) => [([[a]] -> a, a)] -- constr, constr weight-pairConstrVs = [(noSubset, 1)]---- It's not clear what happens with contradictory constraints like these:--- It looks like one pair satisfies strict subset, and the other pairs all intersect--- pairConstrVs = [(strictSubset, 1), (noIntersectExt, 1)]---- Corners for hard-coded bounding box constraint.-leftb :: Floating a => a-leftb = -200--rightb :: Floating a => a-rightb = 100--botb :: Floating a => a-botb = 0--topb :: Floating a => a-topb = 200
+ src/Serializer.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_HADDOCK prune #-}++module Serializer where++import Env+import GenOptProblem+import Optimizer+import Style+import SubstanceTokenizer+import Utils++import Data.Aeson+import Data.Aeson.TH+import GHC.Generics+import qualified Numeric.LinearAlgebra as L+import System.Random (StdGen)+import Text.Megaparsec++instance ToJSONKey Name++instance FromJSONKey Name++instance ToJSONKey TypeVar++instance FromJSONKey TypeVar++instance ToJSONKey T++instance FromJSONKey T++instance ToJSONKey Var++instance FromJSONKey Var++--------------------------------------------------------------------------------+-- TODO: slowly move all the JSON decls other than the ones in Server to+-- this module+deriveJSON defaultOptions ''SourcePosition++deriveJSON defaultOptions ''Pos++deriveJSON defaultOptions ''SourcePos++deriveJSON defaultOptions ''Translation++deriveJSON defaultOptions ''Name++deriveJSON defaultOptions ''FieldExpr++deriveJSON defaultOptions ''TagExpr++deriveJSON defaultOptions ''Expr++deriveJSON defaultOptions ''AnnoFloat++deriveJSON defaultOptions ''BinaryOp++deriveJSON defaultOptions ''UnaryOp++deriveJSON defaultOptions ''PropertyDecl++deriveJSON defaultOptions ''Path++deriveJSON defaultOptions ''Var++deriveJSON defaultOptions ''BindingForm++deriveJSON defaultOptions ''StyVar++deriveJSON defaultOptions ''VarEnv++deriveJSON defaultOptions ''TypeVar++deriveJSON defaultOptions ''T++deriveJSON defaultOptions ''TypeCtorApp++deriveJSON defaultOptions ''TypeConstructor++deriveJSON defaultOptions ''Arg++deriveJSON defaultOptions ''K++deriveJSON defaultOptions ''ValConstructor++deriveJSON defaultOptions ''Y++deriveJSON defaultOptions ''Type++deriveJSON defaultOptions ''Operator++deriveJSON defaultOptions ''PredicateEnv++deriveJSON defaultOptions ''StmtNotationRule++deriveJSON defaultOptions ''Predicate1++deriveJSON defaultOptions ''Prop++deriveJSON defaultOptions ''Predicate2++deriveJSON defaultOptions ''SubstanceTokenizer.Token++-- TODO: de-lambdaize this to make it serializable+-- deriveJSON defaultOptions ''Policy+deriveJSON defaultOptions ''Params++deriveJSON defaultOptions ''Fn++deriveJSON defaultOptions ''StdGen++deriveJSON defaultOptions ''PolicyParams++deriveJSON defaultOptions ''OptType++deriveJSON defaultOptions ''OptStatus++deriveJSON defaultOptions ''BfgsParams++deriveJSON defaultOptions ''GenOptProblem.State++--------------------------------------------------------------------------------+-- Interface+deriveJSON defaultOptions ''CompilerError++deriveJSON defaultOptions ''RuntimeError
src/Server.hs view
@@ -1,110 +1,561 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}+-- | "Server" contains functions that serves the Penrose runtime over+-- websockets connection.+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK prune #-} module Server where-import Shapes-import GHC.Generics-import Data.Monoid (mappend)-import Data.Text (Text)-import Control.Monad (forM_, forever)-import Control.Monad.IO.Class (liftIO)-import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Runtime as R-import qualified Network.WebSockets as WS-import GHC.Float (float2Double)-import Control.Exception-import System.Time--- import System.Posix.Unistd(usleep)-import Data.Char (isPunctuation, isSpace)-import Data.Aeson-import Data.Maybe (fromMaybe) +import Control.Concurrent (MVar, forkIOWithUnmask, modifyMVar_,+ newMVar, readMVar)+import Control.Exception+import Control.Monad (forever, void)+import Data.Aeson+import Data.Tuple.Extra (fst3)+import Data.UUID+import Env (VarEnv)+import GenOptProblem+import GHC.Generics+import Interface+import qualified Network.Socket as S+import qualified Network.WebSockets as WS+import Style+import System.Console.Pretty (Color (..), Style (..), bgColor)+import qualified System.Console.Pretty as Console+import System.IO (Handle, stderr)+import System.Log.Formatter+import System.Log.Handler (setFormatter)+import System.Log.Handler.Simple (GenericHandler (..), fileHandler,+ streamHandler)+import System.Log.Logger (Priority (..), debugM, errorM,+ infoM, rootLoggerName,+ setHandlers, setLevel,+ updateGlobalLogger, warningM)+import System.Random -type ServerState = R.State-data FeedBack = Cmd Command | Drag DragEvent | Update UpdateShapes deriving (Show, Generic)-data Command = Command { command :: String } deriving (Show, Generic)-data DragEvent = DragEvent { name :: String, xm :: Float, ym :: Float } deriving (Show, Generic)-data UpdateShapes = UpdateShapes { objs :: [Obj] } deriving (Show, Generic)-instance FromJSON FeedBack-instance FromJSON Command-instance FromJSON DragEvent-instance FromJSON UpdateShapes+--------------------------------------------------------------------------------+-- Types+data Packet a = Packet+ { typ :: String+ , contents :: a+ } deriving (Generic) +instance (ToJSON a) => ToJSON (Packet a) where+ toJSON Packet {typ = t, contents = c} = object ["type" .= t, "contents" .= c] -wsSendJSON :: ToJSON j => WS.Connection -> j -> IO ()-wsSendJSON conn obj = WS.sendTextData conn $ encode obj+-- | TODO+type ClientID = UUID --- wsReceiveJSON :: (WS.TextProtocol p, FromJSON j) => WS.WebSockets p (Maybe j)--- wsReceiveJSON = fmap decode WS.receiveData+-- | TODO+type ServerState = [Client] -servePenrose :: String -> Int -> R.State -> IO ()-servePenrose domain port initState = do- putStrLn "Starting Server..."- WS.runServer domain port $ application initState+-- | TODO+type Client = (ClientID, WS.Connection, ClientState) -application :: ServerState -> WS.ServerApp-application s pending = do- conn <- WS.acceptRequest pending- WS.forkPingThread conn 30 -- To keep the connection alive- wsSendJSON conn (R.objs s)- loop conn (step s)+-- | TODO+data ClientState+ = Editor VarEnv+ StyProg+ (Maybe BackendState) -- TODO: no longer used, remove+ | Renderer BackendState -- TODO: no longer used, remove+ | Stateless -loop :: WS.Connection -> R.State -> IO ()-loop conn s- | R.optStatus ( R.params s) == R.EPConverged = do- putStrLn "Optimization completed."- -- wsSendJSON conn (R.objs s) -- TODO: is this necessary?- processCommand conn s- | R.autostep s = stepAndSend conn s- | otherwise = processCommand conn s+-- | TODO+type BackendState = GenOptProblem.State -processCommand :: WS.Connection -> R.State -> IO ()-processCommand conn s = do- -- putStrLn "Receiving Commands"- msg_json <- WS.receiveData conn- case decode msg_json of- Just e -> case e of- Cmd (Command cmd) -> executeCommand cmd conn s- Drag (DragEvent name xm ym) -> dragUpdate name xm ym conn s- Update (UpdateShapes objs) -> updateShapes objs conn s- Nothing -> error "Error reading JSON"+--------------------------------------------------------------------------------+-- RESTful server+data Request+ = Step Int+ State+ | Resample Int+ State+ | StepUntilConvergence State+ | CompileTrio String+ String+ String+ | GetEnv String+ String+ deriving (Generic) -updateShapes :: [Obj] -> WS.Connection -> R.State -> IO ()-updateShapes newObjs conn s = if R.autostep s then stepAndSend conn news else loop conn news- where- news = s { R.objs = newObjs, R.params = (R.params s) { R.weight = R.initWeight, R.optStatus = R.NewIter }}+instance FromJSON Request -dragUpdate :: String -> Float -> Float -> WS.Connection -> R.State -> IO ()-dragUpdate name xm ym conn s = if R.autostep s then stepAndSend conn news else loop conn news- where- newObjs = map (\x ->- if getName x == name- then setX (xm + getX x) $ setY (-ym + getY x) x- else x)- (R.objs s)- news = s { R.objs = newObjs, R.params = (R.params s) { R.weight = R.initWeight, R.optStatus = R.NewIter }}+instance ToJSON Request -executeCommand :: String -> WS.Connection -> R.State -> IO ()-executeCommand cmd conn s- | cmd == "resample" = resampleAndSend conn s- | cmd == "step" = stepAndSend conn s- | cmd == "autostep" = loop conn (s { R.autostep = not $ R.autostep s })- | otherwise = putStrLn ("Can't recognize command " ++ cmd)+processRequests :: Client -> IO ()+processRequests client@(_, conn, _) = do+ logDebug client "Waiting for Commands"+ msg_json <- WS.receiveData conn+ logDebug client $ "Messege received from frontend: \n" ++ show msg_json+ case decode msg_json of+ Just e ->+ case e of+ Step steps s -> sendSafe "state" $ Interface.step s steps+ Resample samples s -> sendSafe "state" $ Interface.resample s samples+ StepUntilConvergence s ->+ sendSafe "state" $ Interface.stepUntilConvergence s+ CompileTrio sub sty elm ->+ sendSafe "compilerOutput" $ Interface.compileTrio sub sty elm+ GetEnv sub elm -> sendSafe "varEnv" $ Interface.getEnv sub elm+ Nothing -> do+ logError client "Error reading JSON"+ processRequests client+ logDebug client $ "Messege received and decoded successfully."+ processRequests client+ where+ sendSafe :: (ToJSON a, ToJSON b) => String -> Either a b -> IO ()+ sendSafe flag res =+ case res of+ Right state -> wsSendPacket conn Packet {typ = flag, contents = state}+ Left error -> wsSendPacket conn Packet {typ = "error", contents = error} +--------------------------------------------------------------------------------+-- Server-level functions+newServerState :: ServerState+newServerState = [] -resampleAndSend, stepAndSend :: WS.Connection -> R.State -> IO ()-resampleAndSend conn s = do- let (objs', rng') = R.sampleConstrainedState (R.rng s) (R.objs s) (R.constrs s)- let nexts = s { R.objs = objs', R.down = False, R.rng = rng', R.params = (R.params s) { R.weight = R.initWeight, R.optStatus = R.NewIter } }- wsSendJSON conn (R.objs nexts)- loop conn nexts-stepAndSend conn s = do- let nexts = step s- wsSendJSON conn (R.objs nexts)- loop conn nexts+numClients :: ServerState -> Int+numClients = length -step :: R.State -> R.State-step s = s { R.objs = objs', R.params = params' }- where (objs', params') = R.stepObjs (float2Double R.calcTimestep) (R.params s) (R.objs s)+addClient :: Client -> ServerState -> ServerState+addClient client clients = client : clients++removeClient :: Client -> ServerState -> ServerState+removeClient client = filter ((/= fst3 client) . fst3)++newUUID :: IO UUID+newUUID = randomIO++idString :: Client -> String+idString = toString . fst3++prettyAddress :: String -> Int -> String+prettyAddress domain port = "ws://" ++ domain ++ ":" ++ show port ++ "/"++-- | 'serveEditor' starts the Penrose server in the editor mode and compile user's input programs dynamically+serveEditor ::+ String -- ^ the domain of the server+ -> Int -- ^ port number of the server+ -> Bool -- ^ verbosity option+ -> IO ()+serveEditor domain port isVerbose = do+ initState <- newMVar newServerState+ putStrLn $ "Penrose editor server started on " ++ prettyAddress domain port+ putStrLn "Waiting for clients to connect..."+ catch (runServer domain port $ handleClient initState isVerbose) handler+ where+ handler :: ErrorCall -> IO ()+ handler e = putStrLn "Internal server Error"++handleClient ::+ MVar ServerState -- ^ current list of clients+ -> Bool -- ^ verbosity option+ -> WS.ServerApp+handleClient state isVerbose pending = do+ conn <- WS.acceptRequest pending+ WS.forkPingThread conn 30 -- To keep the connection alive+ clients <- readMVar state+ clientID <- newUUID+ let client = (clientID, conn, Stateless)+ let logLevel = if isVerbose then DEBUG else INFO+ myStreamHandler <- fmap withColoredFormatter $ streamHandler stderr logLevel+ updateGlobalLogger rootLoggerName (setHandlers [myStreamHandler])++-- let logPath = "/var/log/penrose-" ++ idString client ++ ".log"+-- myFileHandler <- fmap withFormatter $ fileHandler logPath logLevel+-- updateGlobalLogger+-- rootLoggerName+-- (setHandlers [myStreamHandler, myFileHandler])++ updateGlobalLogger rootLoggerName (setLevel DEBUG)+ flip finally (disconnect client) $ do+ modifyMVar_ state $ \s -> do+ let s' = addClient client s+ return s'+ logInfo client $ "Client connected " ++ toString clientID+ -- start an editor session+ processRequests client+ where+ disconnect client+ = do+ -- Remove client+ modifyMVar_ state $ \s -> return $ removeClient client s+ logInfo client (idString client ++ " disconnected")++--------------------------------------------------------------------------------+-- Client-level functions+-- | 'serveRenderer' is the top-level function that "Main" uses to start serving+-- the Penrose Runtime.+serveRenderer ::+ String -- the domain of the server+ -> Int -- port number of the server+ -> BackendState -- initial state of Penrose Runtime+ -> IO ()+serveRenderer domain port initState = do+ putStrLn $ "Penrose renderer server started on " ++ prettyAddress domain port+ putStrLn "Waiting for the frontend UI to connect..."+ let s = Renderer initState+ catch (runServer domain port $ renderer s) handler+ where+ handler :: ErrorCall -> IO ()+ handler _ = putStrLn "Server Error"++renderer :: ClientState -> WS.ServerApp+renderer (Renderer s) pending = do+ conn <- WS.acceptRequest pending+ WS.forkPingThread conn 30 -- To keep the connection alive+ clientID <- newUUID+ let client = (clientID, conn, Stateless)+ -- send the initial state to the frontend renderer first+ wsSendPacket conn Packet {typ = "state", contents = s}+ processRequests client++--------------------------------------------------------------------------------+-- Logger+withColoredFormatter, withFormatter ::+ GenericHandler Handle -> GenericHandler Handle+withFormatter handler = setFormatter handler formatter+ where+ formatter = simpleLogFormatter ("[$time $loggername $prio]" ++ "\n$msg")++withColoredFormatter handler = setFormatter handler coloredLogFormatter++coloredLogFormatter :: LogFormatter a+coloredLogFormatter _h (prio, msg) loggername+ | prio == DEBUG = formatter Blue+ | prio == INFO = formatter Green+ | prio == ERROR = formatter Red+ where+ formatter color =+ simpleLogFormatter+ (bgColor color $+ Console.style Bold "[$time $loggername $prio]" ++ "\n$msg")+ _h+ (prio, msg)+ loggername++logDebug, logInfo, logError :: Client -> String -> IO ()+logDebug client = debugM (idString client)++logInfo client = infoM (idString client)++logError client = errorM (idString client)++--------------------------------------------------------------------------------+-- WebSocket utils+wsSendPacket :: ToJSON a => WS.Connection -> Packet a -> IO ()+wsSendPacket conn packet = WS.sendTextData conn $ encode packet++-- | This 'runServer' is exactly the same as the one in "Network.WebSocket". Duplicated for calling a customized version of 'runServerWith' with error messages enabled.+runServer ::+ String -- ^ Address to bind+ -> Int -- ^ Port to listen on+ -> WS.ServerApp -- ^ Application+ -> IO () -- ^ Never returns+runServer host port app =+ runServerWith host port WS.defaultConnectionOptions app++-- | A version of 'runServer' which allows you to customize some options.+runServerWith :: String -> Int -> WS.ConnectionOptions -> WS.ServerApp -> IO ()+runServerWith host port opts app =+ S.withSocketsDo $+ bracket+ (WS.makeListenSocket host port)+ S.close+ (\sock ->+ mask_ $+ forever $ do+ allowInterrupt+ (conn, _) <- S.accept sock+ void $+ forkIOWithUnmask $ \unmask ->+ finally (unmask $ runApp conn opts app) (S.close conn))++runApp :: S.Socket -> WS.ConnectionOptions -> WS.ServerApp -> IO ()+runApp socket opts app = do+ sock <- WS.makePendingConnection socket opts+ app sock+--------------------------------------------------------------------------------+-- Old server code for reference+-- -- TODO use the more generic wsSendJSON?+-- wsSendShapes :: WS.Connection -> [Shape Double] -> IO ()+-- wsSendShapes conn shapes = WS.sendTextData conn $ encode packet+-- where packet = Packet { typ = "shapes", contents = shapes }+-- wsSendFrame :: WS.Connection -> Frame -> IO ()+-- wsSendFrame conn frame = WS.sendTextData conn $ encode packet+-- where packet = Packet { typ = "shapes", contents = frame }+-- updateState :: ClientState -> BackendState -> ClientState+-- updateState (Renderer s) s' = Renderer s'+-- updateState (Editor e sty s) s' = Editor e sty $ Just s'+-- getBackendState :: ClientState -> BackendState+-- getBackendState (Renderer s) = s+-- getBackendState (Editor _ _ (Just s)) = s+-- getBackendState (Editor _ _ Nothing) = error "Server error: Backend state has not been initialized yet."+-- data Feedback+-- = Cmd Command+-- | Drag DragEvent+-- | Update UpdateShapes+-- | Edit SubstanceEdit+-- | Recompile RecompileDomain+-- deriving (Generic)+-- data Command = Command { command :: String }+-- deriving (Show, Generic)+-- data DragEvent = DragEvent { name :: String,+-- xm :: Float,+-- ym :: Float }+-- deriving (Show, Generic)+-- data SubstanceEdit = SubstanceEdit { program :: String, enableAutostep :: Bool }+-- deriving (Show, Generic)+-- data RecompileDomain = RecompileDomain { element :: String, style :: String }+-- deriving (Show, Generic)+-- data UpdateShapes = UpdateShapes { shapes :: [Shape Double] }+-- deriving (Show, Generic)+-- data Frame = Frame { flag :: String,+-- shapes :: [Shape Double],+-- ordering :: [String]+-- } deriving (Show, Generic)+-- instance FromJSON Feedback+-- instance FromJSON Command+-- instance FromJSON DragEvent+-- instance FromJSON UpdateShapes+-- instance FromJSON SubstanceEdit+-- instance FromJSON RecompileDomain+-- instance ToJSON Frame+-- loop :: Client -> IO ()+-- loop client@(clientID, conn, clientState)+-- | optStatus (paramsr s) == EPConverged = do+-- logInfo client "Optimization completed."+-- logInfo client ("Current weight: " ++ show (weight (paramsr s)))+-- wsSendFrame conn+-- Frame {+-- flag = "final",+-- ordering = shapeOrdering s,+-- shapes = shapesr s :: [Shape Double]+-- }+-- processCommand client+-- | autostep s = stepAndSend client+-- | otherwise = processCommand client+-- where s = getBackendState clientState+-- -- | In editor mode, the server first waits for a well-formed Substance program+-- -- before accepting any other kinds of commands. The default action on other+-- -- commands is to continue waiting without crashing+-- waitSubstance :: Client -> IO ()+-- waitSubstance client@(clientID, conn, clientState) = do+-- infoM (toString clientID) "Waiting for Substance program..."+-- msg_json <- WS.receiveData conn+-- case decode msg_json of+-- Just e -> case e of+-- Edit (SubstanceEdit subProg auto) -> substanceEdit subProg auto client+-- Recompile (RecompileDomain element style) -> recompileDomain element style client+-- _ -> continue+-- Nothing -> continue+-- where continue = do+-- warningM (toString clientID) "Invalid command. Returning to wait for Substance program"+-- waitSubstance client+-- -- } COMBAK: abstract this logic out to `wait`+-- waitUpdate :: Client -> IO ()+-- waitUpdate client@(clientID, conn, clientState) = do+-- logInfo client "Waiting for image/label dimension update"+-- msg_json <- WS.receiveData conn+-- case decode msg_json of+-- Just e -> case e of+-- Update (UpdateShapes shapes) -> updateShapes shapes client+-- _ -> continue+-- Nothing -> continue+-- where continue = do+-- warningM (toString clientID) "Invalid command. Returning to wait for image/label update."+-- waitUpdate client+-- substanceError, elementError, styleError :: Client -> CompilerError -> IO ()+-- substanceError client@(_, conn, _) e = do+-- logError client $ "Substance compiler error: " ++ show e+-- wsSendPacket conn Packet { typ = "error", contents = e}+-- waitSubstance client+-- elementError client@(_, conn, _) e = do+-- logError client $ "Element parser error: " ++ show e+-- wsSendPacket conn Packet { typ = "error", contents = e}+-- waitSubstance client+-- styleError client@(_, conn, _) e = do+-- logError client $ "Style parser error: " ++ show e+-- wsSendPacket conn Packet { typ = "error", contents = e}+-- waitSubstance client+-- styleRuntimeError :: Client -> ErrorCall -> IO ()+-- styleRuntimeError client@(_, conn, _) e = do+-- logError client $ "Style runtime error: " ++ show e+-- wsSendPacket conn Packet { typ = "error", contents = show e}+-- waitSubstance client+-- -- -- TODO: this match might be redundant, but not sure why the linter warns that.+-- -- substanceError client s _ = do+-- -- putStrLn "Substance compiler error: Unknown error."+-- -- waitSubstance c s+-- -- COMBAK: this function should be updated to remove+-- processCommand :: Client -> IO ()+-- processCommand client@(clientID, conn, s) = do+-- logInfo client "Waiting for Commands"+-- msg_json <- WS.receiveData conn+-- logInfo client $ "Messege received from frontend: \n" ++ show msg_json+-- case decode msg_json of+-- Just e -> case e of+-- Cmd (Command cmd) -> executeCommand cmd client+-- Drag (DragEvent name xm ym) -> dragUpdate name xm ym client+-- Edit (SubstanceEdit subProg auto) -> substanceEdit subProg auto client+-- Update (UpdateShapes shapes) -> updateShapes shapes client+-- Recompile (RecompileDomain element style) -> recompileDomain element style client+-- Nothing -> logError client "Error reading JSON"+-- -- TODO: might need to return to `loop`+-- recompileDomain :: String -> String -> Client -> IO ()+-- recompileDomain _ _ client@(_, conn, Renderer s) = do+-- logError client "Cannot change domains in Renderer mode."+-- loop client+-- recompileDomain element style client@(clientID, conn, Editor {}) = do+-- logInfo client "Switching to another domain..."+-- logInfo client $ "Element program received: " ++ element+-- logInfo client $ "Style program received: " ++ style+-- let elementRes = parseElement "" element+-- case elementRes of+-- Right elementEnv -> do+-- -- Send Env to the frontend for language services (for now, bag-of-word autocompletion)+-- wsSendPacket conn $ Packet { typ = "env", contents = elementEnv}+-- let styRes = parseStyle "" style elementEnv+-- case styRes of+-- Right styProg -> do+-- logDebug client ("Style AST:\n" ++ ppShow styProg)+-- let client = (clientID, conn, Editor elementEnv styProg Nothing)+-- waitSubstance client+-- Left err -> styleError client err+-- Left err -> elementError client err+-- substanceEdit :: String -> Bool -> Client -> IO ()+-- substanceEdit subIn _ client@(_, _, Renderer _) =+-- logError client "Server Error: the Substance program cannot be updated when the server is in Renderer mode."+-- substanceEdit subIn auto client@(clientID, conn, Editor env styProg s) = do+-- logInfo client $ "Substance program received: " ++ subIn+-- let subRes = Substance.parseSubstance "" (Sugarer.sugarStmts subIn env) env+-- case subRes of+-- Right subOut@(Substance.SubOut _ (subEnv, _) _) -> do+-- logInfo client $ show subOut+-- -- TODO: store the Style values to reuse on Substance edit+-- -- TODO: pass in any new optimization config values here?+-- wsSendPacket conn $ Packet { typ = "env", contents = subEnv }+-- let styVals = []+-- let optConfig = case s of+-- Nothing -> G.defaultOptConfig+-- Just currState -> oConfig currState+-- styRes <- try (compileStyle styProg subOut styVals optConfig)+-- case styRes of+-- Right newState -> do+-- wsSendFrame conn Frame {+-- flag = "initial",+-- ordering = shapeOrdering newState,+-- shapes = shapesr newState :: [Shape Double]+-- }+-- waitUpdate (clientID, conn, Editor env styProg $ Just newState { G.autostep = auto })+-- Left styError -> styleRuntimeError client styError+-- Left subError -> substanceError client subError+-- updateShapes :: [Shape Double] -> Client -> IO ()+-- updateShapes newShapes client@(clientID, conn, clientState) =+-- let polyShapes = toPolymorphics newShapes+-- uninitVals = map G.toTagExpr $ G.shapes2vals polyShapes $ G.uninitializedPaths s+-- trans' = G.insertPaths (G.uninitializedPaths s) uninitVals (G.transr s)+-- -- -- Respect the optimization policy+-- -- TODO: rewrite this such that it works with the new overallObjFn+-- -- policyFns = currFns $ policyParams s+-- -- newObjFn = G.genObjfn (castTranslation trans') (filter isObjFn policyFns) (filter isConstr policyFns) (G.varyingPaths s)+-- varyMapNew = G.mkVaryMap (G.varyingPaths s) (G.varyingState s)+-- news = s {+-- G.shapesr = polyShapes,+-- G.varyingState = G.shapes2floats polyShapes varyMapNew $ G.varyingPaths s,+-- G.transr = trans',+-- -- G.paramsr = (G.paramsr s) { G.weight = G.initWeight, G.optStatus = G.NewIter, G.overallObjFn = newObjFn, G.bfgsInfo = G.defaultBfgsParams }}+-- G.paramsr = (G.paramsr s) { G.weight = G.initWeight, G.optStatus = G.NewIter, G.bfgsInfo = G.defaultBfgsParams }}+-- nextClientS = updateState clientState news+-- client' = (clientID, conn, nextClientS)+-- in if autostep s+-- then stepAndSend client'+-- else loop client'+-- where s = getBackendState clientState+-- dragUpdate :: String -> Float -> Float -> Client -> IO ()+-- dragUpdate name xm ym client@(clientID, conn, clientState) =+-- let (xm', ym') = (r2f xm, r2f ym)+-- newShapes = map (\shape ->+-- if getName shape == name+-- then dragShape shape xm' ym'+-- else shape)+-- (G.shapesr s)+-- varyMapNew = G.mkVaryMap (G.varyingPaths s) (G.varyingState s)+-- news = s { G.shapesr = newShapes,+-- G.varyingState = G.shapes2floats newShapes varyMapNew $ G.varyingPaths s,+-- G.paramsr = (G.paramsr s) { G.weight = G.initWeight, G.optStatus = G.NewIter, G.bfgsInfo = G.defaultBfgsParams }}+-- nextClientS = updateState clientState news+-- client' = (clientID, conn, nextClientS)+-- in if autostep s+-- then stepAndSend client'+-- else loop client'+-- where s = getBackendState clientState+-- dragShape :: Autofloat a => Shape a -> a -> a -> Shape a+-- dragShape shape dx dy+-- | shape `is` "Line" =+-- trRaw "here" $ move "startX" dx $+-- move "startY" dy $+-- move "endX" dx $+-- move "endY" dy shape+-- | shape `is` "Image" =+-- move "centerX" dx $+-- move "centerY" dy shape+-- | shape `is` "Arrow" =+-- move "startX" dx $+-- move "startY" dy $+-- move "endX" dx $+-- move "endY" dy shape+-- | shape `is` "Curve" =+-- movePath (dx, dy) shape+-- | otherwise = setX (FloatV (dx + getX shape)) $ setY (FloatV (dy + getY shape)) shape+-- move :: Autofloat a => PropID -> a -> Shape a -> Shape a+-- move prop dd s = set s prop (FloatV (dd + getNum s prop))+-- executeCommand :: String -> Client -> IO ()+-- executeCommand cmd client@(clientID, conn, clientState)+-- | cmd == "resample" = resampleAndSend client+-- | cmd == "step" = stepAndSend client+-- | cmd == "autostep" =+-- let os = getBackendState clientState+-- os' = os { autostep = not $ autostep os }+-- in loop (clientID, conn, updateState clientState os')+-- | otherwise = logError client ("Can't recognize command " ++ cmd)+-- resampleAndSend, stepAndSend :: Client -> IO ()+-- resampleAndSend client@(clientID, conn, clientState) = do+-- -- Sample several states and choose the one with lowest energy+-- let news = G.resampleBest G.numStateSamples s+-- let (newShapes, _, _) = evalTranslation news+-- wsSendFrame conn+-- Frame {+-- flag = "initial",+-- ordering = shapeOrdering news,+-- shapes = newShapes+-- }+-- let nextClientS = updateState clientState news+-- let client' = (clientID, conn, nextClientS)+-- -- NOTE: could have called `loop` here, but this would result in a race condition between autostep and updateShapes somehow. Therefore, we explicitly transition to waiting for an update on image/label sizes whenever resampled.+-- waitUpdate client'+-- where s = getBackendState clientState+-- stepAndSend client@(clientID, conn, clientState) = do+-- --------------------------------------------------------------------------------+-- -- DEBUG: performance test for JSON encode/decode speed+-- -- let s' = getBackendState clientState+-- -- let s = unsafePerformIO $ do+-- -- B.writeFile "state.json" (encode s')+-- -- stateStr <- B.readFile "state.json"+-- -- return (fromMaybe (error "json decode error") $ decode stateStr)+-- -- let nexts = O.step s+-- --------------------------------------------------------------------------------+-- -- COMBAK: revert+-- let s = getBackendState clientState+-- let nexts = O.step s+-- wsSendFrame conn+-- Frame {+-- flag = "running",+-- ordering = shapeOrdering s,+-- shapes = shapesr s :: [Shape Double]+-- }+-- -- loop conn (trRaw "state:" nexts)+-- loop (clientID, conn, updateState clientState nexts)
+ src/ShadowMain.hs view
@@ -0,0 +1,111 @@+-- | Main module of the Penrose system (split out for testing; Main is the real main)+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK prune #-}++module ShadowMain where++import qualified Control.Concurrent as CC+import Control.Exception+import Control.Monad (forM_, when)+import Control.Monad.Trans+import Data.Aeson+import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.List as L (intercalate)+import qualified Data.List.Split as LS (splitOn)+import qualified Data.Map.Strict as M+import qualified Data.Text.Lazy as T+import Data.Text.Lazy.Encoding (decodeUtf8)+import Debug.Trace+import qualified Element as D+import qualified Env as E+import qualified GenOptProblem as G+import Interface+import Network.HTTP.Types.Status+import qualified Optimizer as O+import Plugins+import Prelude hiding (catch)+import qualified Server+import qualified Style as S+import qualified Substance as C+import qualified SubstanceJSON as J+import qualified Sugarer+import System.Console.Docopt+import System.Console.Pretty (Color (..), Style (..), bgColor,+ color, style, supportsPretty)+import System.Environment+import System.Exit+import System.IO+import System.IO.Error hiding (catch)+import qualified Text.Megaparsec as MP (parseErrorPretty, runParser)+import Text.Show.Pretty+import Utils+import Web.Scotty++default (Int, Float)++-- when false, executes headless for profiling+useFrontend :: Bool+useFrontend = True++argPatterns :: Docopt+argPatterns = [docoptFile|USAGE.txt|]++getArgOrExit = getArgOrExitWith argPatterns++-- | `shadowMain` runs the Penrose system+shadowMain :: IO ()+shadowMain = do+ args <- parseArgsOrExit argPatterns =<< getArgs+ domain <- args `getArgOrExit` longOption "domain"+ port <- args `getArgOrExit` longOption "port"+ config <- args `getArgOrExit` longOption "config"+ if args `isPresent` (command "editor")+ then let isVerbose = args `isPresent` (longOption "verbose")+ in Server.serveEditor domain (read port) isVerbose+ else do+ subFile <- args `getArgOrExit` argument "substance"+ styFile <- args `getArgOrExit` argument "style"+ elementFile <- args `getArgOrExit` argument "element"+ penroseRenderer subFile styFile elementFile domain config $ read port++penroseRenderer ::+ String -> String -> String -> String -> String -> Int -> IO ()+penroseRenderer subFile styFile elementFile domain configPath port = do+ subIn <- readFile subFile+ styIn <- readFile styFile+ elementIn <- readFile elementFile+ initState <-+ case Interface.compileTrio subIn styIn elementIn of+ Left err -> error $ show err+ Right (s, _) -> return s+ -- Read optimization config and so it can be included in the initial state+ configStr <- B.readFile configPath+ let configBstr = (decode configStr) :: Maybe G.OptConfig+ let optConfig =+ case configBstr of+ Nothing -> error "couldn't read opt config JSON"+ Just x -> x+ putStrLn "Opt config:\n"+ putStrLn $ show optConfig+ let state = initState {G.oConfig = optConfig}+ if useFrontend+ then Server.serveRenderer domain port state+ else let numTrials = 1000+ in let res = map (\x -> stepsWithoutServer state) [1 .. numTrials]+ in putStrLn $ show $ map G.varyingState res -- Needed so all of res is evaluated, but don't spend so much time prettyprinting++stepsWithoutServer :: G.State -> G.State+stepsWithoutServer initState =+ let (finalState, numSteps) =+ head $ dropWhile notConverged $ iterate stepAndCount (initState, 0)+ in trace ("\nnumber of outer steps: " ++ show numSteps) $ finalState+ where+ stepAndCount (s, n) = (O.step s, n + 1)+ notConverged (s, n) =+ G.optStatus (G.paramsr s) /= G.EPConverged && n < maxSteps+ maxSteps = 10 ** 3 -- Not sure how many steps it usually takes to converge
src/Shapes.hs view
@@ -1,410 +1,1439 @@------------------------------------------------------------------------------------ Geometry module in Penrose--- Currently supporting:--- Circle--- Square--- Point--- Arrow--- Label----------------------------------------------------------------------------------{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}--module Shapes where--- module Shapes (Obj, Obj') where-import Data.Aeson-import Data.Monoid ((<>))-import GHC.Generics-import Graphics.Gloss--type Name = String--class Located a where- getX :: a -> Float- getY :: a -> Float- setX :: Float -> a -> a- setY :: Float -> a -> a--class Selectable a where- select :: a -> a- deselect :: a -> a- selected :: a -> Bool--class Sized a where- getSize :: a -> Float- setSize :: Float -> a -> a--class Named a where- getName :: a -> Name- setName :: Name -> a -> a---- data BBox = BBox {--- cx :: Float,--- cy :: Float,--- h :: Float,--- w :: Float--- } deriving (Show, Eq, Generic)--- instance ToJSON BBox--- instance FromJSON BBox----------data SolidArrow = SolidArrow { startx :: Float- , starty :: Float- , endx :: Float- , endy :: Float- , thickness :: Float -- the maximum thickness, i.e. the thickness of the head- , selsa :: Bool -- is the circle currently selected? (mouse is dragging it)- , namesa :: String- , colorsa :: Color- -- , bbox :: BBox- }- deriving (Eq, Show, Generic)--instance Located SolidArrow where- -- getX a = endx a - startx a- -- getY a = endy a - starty a- getX a = startx a- getY a = starty a- setX x c = c { startx = x } -- TODO- setY y c = c { starty = y }--instance Selectable SolidArrow where- select x = x { selsa = True }- deselect x = x { selsa = False }- selected x = selsa x--instance Named SolidArrow where- getName a = namesa a- setName x a = a { namesa = x }--instance ToJSON SolidArrow-instance FromJSON SolidArrow-----------data Circ = Circ { xc :: Float- , yc :: Float- , r :: Float- , selc :: Bool -- is the circle currently selected? (mouse is dragging it)- , namec :: String- , colorc :: Color }- deriving (Eq, Show, Generic)--instance Located Circ where- getX c = xc c- getY c = yc c- setX x c = c { xc = x }- setY y c = c { yc = y }--instance Selectable Circ where- select x = x { selc = True }- deselect x = x { selc = False }- selected x = selc x--instance Sized Circ where- getSize x = r x- setSize size x = x { r = size }--instance Named Circ where- getName c = namec c- setName x c = c { namec = x }--instance ToJSON Circ-instance FromJSON Circ--------------------------data Square = Square { xs :: Float- , ys :: Float- , side :: Float- , ang :: Float -- angle for which the obj is rotated- , sels :: Bool -- is the circle currently selected? (mouse is dragging it)- , names :: String- , colors :: Color }- deriving (Eq, Show, Generic)--instance Located Square where- getX s = xs s- getY s = ys s- setX x s = s { xs = x }- setY y s = s { ys = y }--instance Selectable Square where- select x = x { sels = True }- deselect x = x { sels = False }- selected x = sels x--instance Sized Square where- getSize x = side x- setSize size x = x { side = size }--instance Named Square where- getName s = names s- setName x s = s { names = x }--instance ToJSON Square-instance FromJSON Square----------data Label = Label { xl :: Float- , yl :: Float- , wl :: Float- , hl :: Float- , textl :: String- -- , scalel :: Float -- calculate h,w from it- , sell :: Bool -- selected label- , namel :: String }- deriving (Eq, Show, Generic)--instance Located Label where- getX l = xl l- getY l = yl l- setX x l = l { xl = x }- setY y l = l { yl = y }--instance Selectable Label where- select x = x { sell = True }- deselect x = x { sell = False }- selected x = sell x--instance Sized Label where- getSize x = xl x -- TODO generalize label size, distance to corner? ignores scale- setSize size x = x { xl = size, yl = size } -- TODO currently sets both of them, ignores scale- -- changing a label's size doesn't actually do anything right now, but should use the scale- -- and the base font size--instance Named Label where- getName l = namel l- setName x l = l { namel = x }--instance ToJSON Label-instance FromJSON Label---------data Pt = Pt { xp :: Float- , yp :: Float- , selp :: Bool- , namep :: String }- deriving (Eq, Show, Generic)--instance Located Pt where- getX p = xp p- getY p = yp p- setX x p = p { xp = x }- setY y p = p { yp = y }--instance Selectable Pt where- select x = x { selp = True }- deselect x = x { selp = False }- selected x = selp x--instance Named Pt where- getName p = namep p- setName x p = p { namep = x }--instance ToJSON Pt-instance FromJSON Pt--data Obj = S Square- | C Circ- | L Label- | P Pt- | A SolidArrow- deriving (Eq, Show, Generic)--instance ToJSON Obj-instance FromJSON Obj--instance FromJSON Color where- parseJSON = withObject "Color" $ \v -> makeColor- <$> v .: "r"- <*> v .: "g"- <*> v .: "b"- <*> v .: "a"--instance ToJSON Color where- -- this generates a Value- toJSON c =- let (r, g, b, a) = rgbaOfColor c in- object ["r" .= r, "g" .= g, "b" .= b, "a" .= a]- toEncoding c =- let (r, g, b, a) = rgbaOfColor c in- pairs ("r" .= r <> "g" .= g <> "b" .= b <> "a" .= a)---- TODO: is there some way to reduce the top-level boilerplate?-instance Located Obj where- getX o = case o of- C c -> getX c- L l -> getX l- P p -> getX p- S s -> getX s- A a -> getX a- getY o = case o of- C c -> getY c- L l -> getY l- P p -> getY p- S s -> getY s- A a -> getY a- setX x o = case o of- C c -> C $ setX x c- L l -> L $ setX x l- P p -> P $ setX x p- S s -> S $ setX x s- A a -> A $ setX x a- setY y o = case o of- C c -> C $ setY y c- L l -> L $ setY y l- P p -> P $ setY y p- S s -> S $ setY y s- A a -> A $ setY y a--instance Selectable Obj where- select x = case x of- C c -> C $ select c- L l -> L $ select l- P p -> P $ select p- S s -> S $ select s- A a -> A $ select a- deselect x = case x of- C c -> C $ deselect c- L l -> L $ deselect l- P p -> P $ deselect p- S s -> S $ deselect s- A a -> A $ deselect a- selected x = case x of- C c -> selected c- L l -> selected l- P p -> selected p- S s -> selected s- A a -> selected a--instance Sized Obj where- getSize o = case o of- C c -> getSize c- S s -> getSize s- L l -> getSize l- setSize x o = case o of- C c -> C $ setSize x c- L l -> L $ setSize x l- S s -> S $ setSize x s--instance Named Obj where- getName o = case o of- C c -> getName c- L l -> getName l- P p -> getName p- S s -> getName s- A a -> getName a- setName x o = case o of- C c -> C $ setName x c- L l -> L $ setName x l- P p -> P $ setName x p- S s -> S $ setName x s- A a -> A $ setName x a--data SolidArrow' a = SolidArrow' { startx' :: a- , starty' :: a- , endx' :: a- , endy' :: a- , thickness' :: a -- the maximum thickness, i.e. the thickness of the head- , selsa' :: Bool -- is the circle currently selected? (mouse is dragging it)- , namesa' :: String- , colorsa' :: Color }- deriving (Eq, Show)--data Circ' a = Circ' { xc' :: a- , yc' :: a- , r' :: a- , selc' :: Bool -- is the circle currently selected? (mouse is dragging it)- , namec' :: String- , colorc' :: Color }- deriving (Eq, Show)--data Label' a = Label' { xl' :: a- , yl' :: a- , wl' :: a- , hl' :: a- , textl' :: String- , sell' :: Bool -- selected label- , namel' :: String }- deriving (Eq, Show)--data Pt' a = Pt' { xp' :: a- , yp' :: a- , selp' :: Bool- , namep' :: String }- deriving (Eq, Show)--data Square' a = Square' { xs' :: a- , ys' :: a- , side' :: a- , ang' :: Float -- angle for which the obj is rotated- , sels' :: Bool- , names' :: String- , colors' :: Color }- deriving (Eq, Show)--instance Named (SolidArrow' a) where- getName sa = namesa' sa- setName x sa = sa { namesa' = x }--instance Named (Circ' a) where- getName c = namec' c- setName x c = c { namec' = x }--instance Named (Square' a) where- getName s = names' s- setName x s = s { names' = x }--instance Named (Label' a) where- getName l = namel' l- setName x l = l { namel' = x }--instance Named (Pt' a) where- getName p = namep' p- setName x p = p { namep' = x }--instance Named (Obj' a) where- getName o = case o of- C' c -> getName c- L' l -> getName l- P' p -> getName p- S' s -> getName s- A' a -> getName a- setName x o = case o of- C' c -> C' $ setName x c- S' s -> S' $ setName x s- L' l -> L' $ setName x l- P' p -> P' $ setName x p- A' a -> A' $ setName x a---- instance Located (Obj' a) where--- getX o = case o of--- C' c -> xc' c--- L' l -> xl' l--- P' p -> xp' p--- S' s -> xs' s--- A' a -> startx' a--- getY o = case o of--- C' c -> yc' c--- L' l -> yl' l--- P' p -> yp' p--- S' s -> ys' s--- A' a -> starty' a- -- setX x o = case o of- -- C' c -> C $ setX' x c- -- L' l -> L $ setX' x l- -- P' p -> P $ setX' x p- -- S' s -> S $ setX' x s- -- A' a -> A $ setX' x a- -- setY y o = case o of- -- C' c -> C' $ setY' y c- -- L' l -> L' $ setY' y l- -- P' p -> P' $ setY' y p- -- S' s -> S' $ setY' y s- -- A' a -> A' $ setY' y a---data Obj' a = C' (Circ' a) | L' (Label' a) | P' (Pt' a) | S' (Square' a)- | A' (SolidArrow' a) deriving (Eq, Show)+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK prune #-}++module Shapes where++import Data.Aeson (FromJSON, ToJSON, toJSON)+import Data.List (foldl')+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Debug.Trace+import GHC.Generics+import System.Random+import Transforms+import Utils++default (Int, Float)++-- import Language.Haskell.TH+--+-- type Autofloat a = (RealFloat a, Floating a, Real a, Show a, Ord a)+-- type Pt2 a = (a, a)+-- genShapeType :: [ShapeTypeStr] -> Q [Dec]+-- genShapeType shapeTypes = do+-- let mkconstructor n = NormalC (mkName n) []+-- constructors = map mkconstructor shapeTypes+-- return [DataD [] (mkName "ShapeT") [] Nothing constructors []]+--------------------------------------------------------------------------------+-- Types+-- | shape can have multiple pieces, e.g. multiple "M"s+type PathData a = [Path' a]++-- | TODO+-- NOTE: the order of the elements is important+data Path' a+ = Closed [Elem a] -- ^ "Z"+ | Open [Elem a] -- ^ no "Z"+ deriving (Generic, Eq, Show)++instance (FromJSON a) => FromJSON (Path' a)++instance (ToJSON a) => ToJSON (Path' a)++-- | TODO+-- | Arc { x, y, sweep1, … } -- "A" TODO+data Elem a+ = Pt (Pt2 a) -- ^ Replace "M," "L", "H", "V"+ | CubicBez (Pt2 a, Pt2 a, Pt2 a) -- ^ "C": two control pts, 1 endpt+ | CubicBezJoin (Pt2 a, Pt2 a) -- ^ "S": 1 control pt, 1 endpt+ | QuadBez (Pt2 a, Pt2 a) -- ^ "Q": 1 control pt, 1 endpt+ | QuadBezJoin (Pt2 a) -- ^ "T": 1 endpt+ deriving (Generic, Eq, Show)++instance (FromJSON a) => FromJSON (Elem a)++instance (ToJSON a) => ToJSON (Elem a)++-------------- Types+-- | possible values in the argument of computation, constraint, or objectives+-- Used for type checking functions+data ArgVal a+ = GPI (Shape a)+ | Val (Value a)+ deriving (Eq, Show, Generic)++data ArgType+ = GPIType ShapeTypeStr+ | ValueT ValueType+ | OneOf [ShapeTypeStr]+ | AnyGPI+ deriving (Eq, Show)++-- | types of fully evaluated values in Style+data ValueType+ = FloatT+ | IntT+ | BoolT+ | StrT+ | PtT+ | PtListT+ | ListT+ | TupT+ | LListT+ | PathDataT+ | ColorT+ | FileT+ | StyleT+ | TransformT+ | HMatrixT+ | MapT+ | PolygonT+ deriving (Eq, Show)++-- | fully evaluated values in Style+data Value a+ = FloatV a -- ^ floating point number+ | IntV Integer -- ^ integer+ | BoolV Bool -- ^ boolean value+ | StrV String -- ^ string literal+ | PtV (Pt2 a) -- ^ point in R^2+ | PathDataV (PathData a) -- ^ path commands+ | PtListV [Pt2 a] -- ^ a list of points+ | ColorV Color -- ^ an RGBA color value+ | FileV String -- ^ path for image+ | StyleV String -- ^ dotted, etc.+ | ListV [a] -- ^ a list of floats+ | TupV (a, a) -- ^ a tuple of floats+ | LListV [[a]] -- ^ a 2D list of floats+ | HMatrixV (HMatrix a) -- ^ single transformation (homogeneous transformation)+ | PolygonV (Polygon a) -- ^ multiple shapes with holes+ deriving (Generic, Eq, Show)++instance (FromJSON a) => FromJSON (Value a)++instance (ToJSON a) => ToJSON (Value a)++instance (FromJSON a) => FromJSON (ArgVal a)++instance (ToJSON a) => ToJSON (ArgVal a)++-- | returns the type of a 'Value'+typeOf :: (Autofloat a) => Value a -> ValueType+typeOf v =+ case v of+ FloatV _ -> FloatT+ IntV _ -> IntT+ BoolV _ -> BoolT+ StrV _ -> StrT+ PtV _ -> PtT+ PtListV _ -> PtListT+ TupV _ -> TupT+ ListV _ -> ListT+ LListV _ -> LListT+ PathDataV _ -> PathDataT+ ColorV _ -> ColorT+ FileV _ -> FileT+ StyleV _ -> StyleT+ HMatrixV _ -> HMatrixT+ PolygonV _ -> PolygonT++-----------------++toPolymorphics :: [Shape Double] -> (forall a . (Autofloat a) => [Shape a])+toPolymorphics = map toPolymorphic++toPolymorphic :: Shape Double -> (forall a . (Autofloat a) => Shape a)+toPolymorphic (ctor, properties) = (ctor, M.map toPolyProperty properties)++toPolyArgVal :: ArgVal Double -> (forall a . (Autofloat a) => ArgVal a)+toPolyArgVal (GPI x) = GPI $ toPolymorphic x+toPolyArgVal (Val x) = Val $ toPolyProperty x++toPolyProperty :: Value Double -> (forall a . (Autofloat a) => Value a)+toPolyProperty v = case v of+ -- Not sure why these have to be rewritten from scratch...+ FloatV n -> FloatV $ r2f n+ BoolV x -> BoolV x+ StrV x -> StrV x+ IntV x -> IntV x+ PtV p -> PtV $ r2 p+ PtListV xs -> PtListV $ map r2 xs+ ListV xs -> ListV $ map r2f xs+ TupV x -> TupV $ r2 x+ LListV xs -> LListV $ map (map r2f) xs+ ColorV x -> ColorV x+ FileV x -> FileV x+ StyleV x -> StyleV x+ PathDataV es -> PathDataV $ map toPolyPath es+ HMatrixV m -> HMatrixV $ HMatrix { xScale = r2f $ xScale m,+ xSkew = r2f $ xSkew m,+ ySkew = r2f $ ySkew m,+ yScale = r2f $ yScale m,+ dx = r2f $ dx m,+ dy = r2f $ dy m+ }+ PolygonV (b, h, bbox, samples) -> PolygonV $ (+ map (map r2) b, map (map r2) h, map2 r2 bbox, map r2 samples)+ where r2 (x, y) = (r2f x, r2f y)++toPolyPath :: Path' Double -> (forall a . (Autofloat a) => Path' a)+toPolyPath (Closed es) = Closed $ map toPolyElem es+toPolyPath (Open es) = Open $ map toPolyElem es++toPolyElem :: Elem Double -> (forall a . (Autofloat a) => Elem a)+toPolyElem (Pt p) = Pt $ r2ft p+toPolyElem (CubicBez (p0, p1, p2)) = CubicBez (r2ft p0, r2ft p1, r2ft p2)+toPolyElem (CubicBezJoin (p0, p1)) = CubicBezJoin (r2ft p0, r2ft p1)+toPolyElem (QuadBez (p0, p1)) = QuadBez (r2ft p0, r2ft p1)+toPolyElem (QuadBezJoin p) = QuadBezJoin $ r2ft p+r2ft (x, y) = (r2f x, r2f y)++-- | the type string of a shape+type ShapeTypeStr = String+-- | the string identifier of a property+type PropID = String++--------- new+type PropertiesDef2 a = M.Map PropID (ValueType, SampledValue a)+-- | Mutually recursive types because we might want to nest a definition of properties (e.g. A.shape.center.x)+type PropertyValue a = Either (SampledValue a) (PropertiesDef2 a)++-- | A dict storing names, types, and default values of properties+type PropertiesDef1 a = M.Map PropID (ValueType, PropertyValue a)+type ShapeDef' a = (ShapeTypeStr, PropertiesDef1 a)+----------++-- | A dict storing names, types, and default values of properties+type PropertiesDef a = M.Map PropID (ValueType, SampledValue a)++-- | definition of a new shape/graphical primitive+-- TODO: rewrite as a record?+type ShapeDef a = (ShapeTypeStr, PropertiesDef a)++type ShapeDefs a = M.Map ShapeTypeStr (ShapeDef a)++-- | A dictionary storing properties of a Style object, e.g. "startx" for 'Arrow'+-- COMBAK: serializer to JSON+type Properties a = M.Map PropID (Value a)++-- | definition of a new shape/graphical primitive+-- TODO: rewrite as a record? Probably better for serialization+type Shape a = (ShapeTypeStr, Properties a)++--------------------------------------------------------------------------------+-- Shape introspection functions++-- | all of the shape defs supported in the system+shapeDefs :: (Autofloat a) => ShapeDefs a+shapeDefs = M.fromList $ zipWithKey shapeDefList+ where zipWithKey = map (\x -> (fst x, x))++shapeDefList :: (Autofloat a) => [ShapeDef a]++shapeDefList = [ anchorPointType, circType, ellipseType, arrowType, braceType, curveType, lineType, rectType, squareType, parallelogramType, imageType, textType, arcType, rectTransformType, polygonType, circTransformType, curveTransformType, lineTransformType, squareTransformType, imageTransformType, ellipseTransformType, parallelogramTransformType, textTransformType ]++-- | retrieve type strings of all shapes+shapeTypes :: (Autofloat a) => ShapeDefs a -> [ShapeTypeStr]+shapeTypes defs = map fst $ M.toList defs++-- | given a type string, find the corresponding shape def+findDef :: (Autofloat a) => ShapeTypeStr -> ShapeDef a+findDef typ = fromMaybe+ (noShapeError "findDef" typ)+ (M.lookup typ shapeDefs)++-- | given a shape def, construct a default shape+defaultShapeOf :: (Autofloat a) => StdGen -> ShapeDef a -> (Shape a, StdGen)+defaultShapeOf g (t, propDict) =+ let (properties, g') = sampleProperties g propDict in+ ((t, properties), g')++defaultValueOf :: (Autofloat a) => StdGen -> PropID -> ShapeDef a -> (Value a, StdGen)+defaultValueOf g prop (t, propDict) =+ let sampleF = snd $ fromMaybe+ (noPropError "defaultValueOf" prop t)+ (M.lookup prop propDict)+ in sampleF g++--------------------------------------------------------------------------------+-- Computing derived properties++-- Initially, a computed property starts with the initial value specified in the shape initialized (e.g. idH)++-- To say that a property is computed: add it to the list in `computedProperties`+-- to say how it is computed: specify the input properties of the shape and write a function that expects them and returns a value+-- Note: DOFs are preserved through this++-- How this feature is implemented: see `computeProperty` in GenOptProblem, which is called by `evalExpr` (as well as anything that calls `evalExpr`, like `evalShape` and `initShape`+-- evalExpr, for a PropertyPath X.f.p, checks if p is in computedProperties for the type of X.f.+-- If so, it evaluates the GPI properties requested by the function, passes the values to the function, and returns the value the function returns+-- If not, then it evaluates the path as usual (by looking up its expr and evaluating it)+-- TODO: move implementation documentation to the wiki and PR++type ComputedValue a = ([Property], [Value a] -> Value a)++computedProperties :: (Autofloat a) => M.Map (ShapeTypeStr, Property) (ComputedValue a)+computedProperties = M.fromList [(("RectangleTransform", "transformation"), rectTransformFn),+ (("CircleTransform", "transformation"), circTransformFn),+ (("Polygon", "transformation"), polygonTransformFn),+ (("CurveTransform", "transformation"), polygonTransformFn),+ -- Same parameters as polygon+ (("LineTransform", "transformation"), polygonTransformFn),+ -- Same parameters as polygon+ (("SquareTransform", "transformation"), squareTransformFn),+ (("ImageTransform", "transformation"), imageTransformFn),+ (("EllipseTransform", "transformation"), ellipseTransformFn),+ (("ParallelogramTransform", "transformation"), parallelogramTransformFn),+ (("TextTransform", "transformation"), textTransformFn),+ (("RectangleTransform", "polygon"), rectPolygonFn),+ (("CircleTransform", "polygon"), circPolygonFn),+ (("CurveTransform", "polygon"), curvePolygonFn),+ (("Polygon", "polygon"), polygonPolygonFn),+ (("LineTransform", "polygon"), linePolygonFn),+ (("SquareTransform", "polygon"), squarePolygonFn),+ (("ImageTransform", "polygon"), imagePolygonFn),+ (("EllipseTransform", "polygon"), ellipsePolygonFn),+ (("ParallelogramTransform", "polygon"), parallelogramPolygonFn),+ (("TextTransform", "polygon"), textPolygonFn)+ ]++rectTransformFn :: (Autofloat a) => ComputedValue a+rectTransformFn = (props, fn)+ where props = ["sizeX", "sizeY", "rotation", "x", "y", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV sizeX, FloatV sizeY, FloatV rotation, + FloatV x, FloatV y, HMatrixV customTransform] = + let defaultTransform = paramsToMatrix (sizeX, sizeY, rotation, x, y) in+ HMatrixV $ customTransform # defaultTransform++polygonTransformFn :: (Autofloat a) => ComputedValue a+polygonTransformFn = (props, fn)+ where props = ["scaleX", "scaleY", "rotation", "dx", "dy", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV scaleX, FloatV scaleY, FloatV rotation, + FloatV dx, FloatV dy, HMatrixV customTransform] = + let defaultTransform = paramsToMatrix (scaleX, scaleY, rotation, dx, dy) in+ HMatrixV $ customTransform # defaultTransform++circTransformFn :: (Autofloat a) => ComputedValue a+circTransformFn = (props, fn)+ where props = ["x", "y", "r", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV r, HMatrixV customTransform] = + let defaultTransform = paramsToMatrix (r, r, 0.0, x, y) in+ HMatrixV $ customTransform # defaultTransform++squareTransformFn :: (Autofloat a) => ComputedValue a+squareTransformFn = (props, fn)+ where props = ["x", "y", "side", "rotation", "transform"]+ fn :: (Autofloat a ) => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV side, FloatV rotation, HMatrixV customTransform] =+ let defaultTransform = paramsToMatrix (side, side, rotation, x, y) in+ HMatrixV $ customTransform # defaultTransform++imageTransformFn :: Autofloat a => ComputedValue a+imageTransformFn = (props, fn)+ where props = ["centerX", "centerY", "scaleX", "scaleY", "rotation", "transform"]+ fn :: (Autofloat a ) => [Value a] -> Value a+ fn [FloatV centerX, FloatV centerY, FloatV scaleX, FloatV scaleY, FloatV rotation, HMatrixV customTransform] =+ let defaultTransform = paramsToMatrix (scaleX, scaleY, rotation, centerX, centerY) in+ HMatrixV $ customTransform # defaultTransform++ellipseTransformFn :: Autofloat a => ComputedValue a+ellipseTransformFn = (props, fn)+ where props = ["x", "y", "rx", "ry", "rotation", "transform"]+ fn :: Autofloat a => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV rx, FloatV ry, FloatV rotation, HMatrixV customTransform] = + let defaultTransform = paramsToMatrix (rx, ry, rotation, x, y) in+ HMatrixV $ customTransform # defaultTransform++textTransformFn :: Autofloat a => ComputedValue a+textTransformFn = (props, fn)+ where props = ["x", "y", "scaleX", "scaleY", "rotation", "transform"]+ fn :: (Autofloat a ) => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV scaleX, FloatV scaleY, FloatV rotation, HMatrixV customTransform] =+ -- Note that this overall transformation does NOT use the "w" and "h" parameters set by the frontend+ let defaultTransform = paramsToMatrix (scaleX, scaleY, rotation, x, y) in+ HMatrixV $ customTransform # defaultTransform++parallelogramTransformFn :: (Autofloat a) => ComputedValue a+parallelogramTransformFn = (props, fn)+ where props = ["width", "height", "rotation", "x", "y", "innerAngle", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV width, FloatV height, FloatV rotation, + FloatV x, FloatV y, FloatV innerAngle, HMatrixV customTransform] = + let defaultTransform = toParallelogram (width, height, rotation, x, y, innerAngle) in+ HMatrixV $ customTransform # defaultTransform++-- TODO: there's a bit of redundant computation with recomputing the full transformation+rectPolygonFn :: (Autofloat a) => ComputedValue a+rectPolygonFn = (props, fn)+ where props = ["sizeX", "sizeY", "rotation", "x", "y", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV sizeX, FloatV sizeY, FloatV rotation, + FloatV x, FloatV y, HMatrixV customTransform] = + let defaultTransform = paramsToMatrix (sizeX, sizeY, rotation, x, y) in+ let fullTransform = customTransform # defaultTransform in+ PolygonV $ transformPoly fullTransform $ toPoly unitSq++polygonPolygonFn :: (Autofloat a) => ComputedValue a+polygonPolygonFn = (props, fn)+ where props = ["scaleX", "scaleY", "rotation", "dx", "dy", "transform", "points"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV scaleX, FloatV scaleY, FloatV rotation, + FloatV dx, FloatV dy, HMatrixV customTransform, PolygonV points] = + let defaultTransform = paramsToMatrix (scaleX, scaleY, rotation, dx, dy) in+ let fullTransform = customTransform # defaultTransform in+ PolygonV $ transformPoly fullTransform points++circPolygonFn :: (Autofloat a) => ComputedValue a+circPolygonFn = (props, fn)+ where props = ["x", "y", "r", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV r, HMatrixV customTransform] = + let defaultTransform = paramsToMatrix (r, r, 0.0, x, y) in+ let fullTransform = customTransform # defaultTransform in+ let res = PolygonV $ transformPoly fullTransform $ toPoly $ circlePoly r in+ {-trace ("getting circle polygon output: " ++ show res)-} res++-- | Polygonize a Bezier curve, even if the curve was originally made using a list of points.+-- TODO: distinguish between filled curves (polygons) and unfilled ones (polylines)+curvePolygonFn :: (Autofloat a) => ComputedValue a+curvePolygonFn = (props, fn)+ where props = ["scaleX", "scaleY", "rotation", "dx", "dy", "transform", "pathData", "strokeWidth", "left-arrowhead", "right-arrowhead"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV scaleX, FloatV scaleY, FloatV rotation, + FloatV dx, FloatV dy, HMatrixV customTransform, PathDataV path, + FloatV strokeWidth, BoolV leftArrow, BoolV rightArrow] = + let defaultTransform = paramsToMatrix (scaleX, scaleY, rotation, dx, dy) in+ let fullTransform = customTransform # defaultTransform in+ PolygonV $ transformPoly fullTransform $ toPoly $ polygonizePathPolygon maxIter strokeWidth leftArrow rightArrow path+ where maxIter = 1 -- TODO: what should this be?++-- | Polygonize a line segment, accounting for its thickness. +-- TODO: would it usually be more efficient to just use a polyline?+linePolygonFn :: (Autofloat a) => ComputedValue a+linePolygonFn = (props, fn)+ where props = ["scaleX", "scaleY", "rotation", "dx", "dy", "transform", "thickness", "startX", "startY", "endX", "endY", "left-arrowhead", "right-arrowhead"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV scaleX, FloatV scaleY, FloatV rotation, + FloatV dx, FloatV dy, HMatrixV customTransform,+ FloatV thickness, FloatV startX, FloatV startY, FloatV endX, FloatV endY,+ BoolV leftArrow, BoolV rightArrow] = + let defaultTransform = paramsToMatrix (scaleX, scaleY, rotation, dx, dy) in+ let fullTransform = customTransform # defaultTransform in+ PolygonV $ transformPoly fullTransform $ toPoly $ extrude thickness (startX, startY) (endX, endY) leftArrow rightArrow++-- TODO: add ones for final properties; also refactor so it's more generic across shapes+squarePolygonFn :: (Autofloat a) => ComputedValue a+squarePolygonFn = (props, fn)+ where props = ["x", "y", "side", "rotation", "transform"]+ fn :: (Autofloat a ) => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV side, FloatV rotation, HMatrixV customTransform] = let+ defaultTransform = paramsToMatrix (side, side, rotation, x, y)+ fullTransform = customTransform # defaultTransform+ in PolygonV $ transformPoly fullTransform $ toPoly unitSq++imagePolygonFn :: Autofloat a => ComputedValue a+imagePolygonFn = (props, fn)+ where props = ["centerX", "centerY", "scaleX", "scaleY", "rotation", "transform", "initWidth", "initHeight"]+ fn :: (Autofloat a ) => [Value a] -> Value a+ fn [FloatV centerX, FloatV centerY, FloatV scaleX, FloatV scaleY, FloatV rotation, HMatrixV customTransform, FloatV initWidth, FloatV initHeight] = let+ -- Note that the unit square is implicitly scaled to (w, h)+ -- (from the frontend) before having the default transform applied+ defaultTransform = paramsToMatrix (scaleX * initWidth, scaleY * initHeight, rotation, centerX, centerY)+ fullTransform = customTransform # defaultTransform + in PolygonV $ transformPoly fullTransform $ toPoly unitSq++ellipsePolygonFn :: Autofloat a => ComputedValue a+ellipsePolygonFn = (props, fn)+ where props = ["x", "y", "rx", "ry", "rotation", "transform"]+ fn :: Autofloat a => [Value a] -> Value a+ fn [FloatV x, FloatV y, FloatV rx, FloatV ry, FloatV rotation, HMatrixV customTransform] = let+ defaultTransform = paramsToMatrix (rx, ry, rotation, x, y)+ fullTransform = customTransform # defaultTransform + in PolygonV $ transformPoly fullTransform $ toPoly $ circlePoly 1++parallelogramPolygonFn :: (Autofloat a) => ComputedValue a+parallelogramPolygonFn = (props, fn)+ where props = ["width", "height", "rotation", "x", "y", "innerAngle", "transform"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV width, FloatV height, FloatV rotation, + FloatV x, FloatV y, FloatV innerAngle, HMatrixV customTransform] = + let defaultTransform = toParallelogram (width, height, rotation, x, y, innerAngle) in+ let fullTransform = customTransform # defaultTransform in+ PolygonV $ transformPoly fullTransform $ toPoly unitSq++textPolygonFn :: (Autofloat a) => ComputedValue a+textPolygonFn = (props, fn)+ where props = ["scaleX", "scaleY", "rotation", "x", "y", "transform", "w", "h"]+ fn :: (Autofloat a) => [Value a] -> Value a+ fn [FloatV scaleX, FloatV scaleY, FloatV rotation, + FloatV x, FloatV y, HMatrixV customTransform, FloatV w, FloatV h] = + -- Note that the unit square is implicitly scaled to (w, h)+ -- (from the frontend) before having the default transform applied+ let defaultTransform = paramsToMatrix (scaleX * w, scaleY * h, rotation, x, y) in+ let fullTransform = customTransform # defaultTransform in+ PolygonV $ transformPoly fullTransform $ toPoly unitSq++--------------------------------------------------------------------------------+-- Property samplers++type SampledValue a = StdGen -> (Value a, StdGen)+type FloatInterval = (Float, Float)++rndInterval :: (Float, Float)+rndInterval = (0, canvasWidth / 6)++-- COMBAK: SHAME. Parametrize the random generators properly!+canvasHeight, canvasWidth :: Float+canvasHeight = 700.0+canvasWidth = 800.0++debugRng :: StdGen+debugRng = mkStdGen seed+ where seed = 16 -- deterministic RNG with seed++constValue :: (Autofloat a) => Value a -> SampledValue a+constValue v g = (v, g)++-- NOTE: this function does not enforce that all values have the same type+sampleDiscrete :: (Autofloat a) => [Value a] -> SampledValue a+sampleDiscrete list g =+ let (idx, g') = randomR (0, length list - 1) g+ in (list !! idx, g')++sampleFloatIn :: (Autofloat a) => FloatInterval -> SampledValue a+sampleFloatIn interval g =+ let (n, g') = randomR interval g in (FloatV $ r2f n, g')++samplePointIn :: (Autofloat a) =>+ (FloatInterval, FloatInterval) -> SampledValue a+samplePointIn (interval1, interval2) g =+ let (n1, g1) = randomR interval1 g+ (n2, g2) = randomR interval2 g1+ in (PtV (r2f n1, r2f n2), g2)++sampleColor :: (Autofloat a) => SampledValue a+sampleColor rng =+ let interval = (0.1, 0.9)+ (r, rng1) = randomR interval rng+ (g, rng2) = randomR interval rng1+ (b, rng3) = randomR interval rng2+ in (ColorV $ makeColor r g b 0.5, rng3)+ -- (a, rng4) = randomR (0.3, 0.7) rng3+ -- in (ColorV $ makeColor r g b a, rng4)++-- | Samples all properties of input shapes+sampleShapes :: (Autofloat a) => StdGen -> [Shape a] -> ([Shape a], StdGen)+sampleShapes g shapes =+ let (shapes', g') = foldl' sampleShape ([], g) shapes+ in (reverse shapes', g')+sampleShape (shapes, g) oldShape@(typ, oldProperties) =+ let (_, propDefs) = findDef typ+ (properties, g') = sampleProperties g propDefs+ shape = (typ, properties)+ namedShape = setName (getName oldShape) shape+ in (namedShape : shapes, g')++sampleProperties :: (Autofloat a) => StdGen -> PropertiesDef a -> (Properties a, StdGen)+sampleProperties g propDefs = M.foldlWithKey sampleProperty (M.empty, g) propDefs++sampleProperty :: (Autofloat a) => (Properties a, StdGen) -> PropID -> (ValueType, SampledValue a) -> (Properties a, StdGen)+sampleProperty (properties, g) propID (typ, sampleF) =+ let (val, g') = sampleF g in (M.insert propID val properties, g')++--------------------------------------------------------------------------------+-- Example shape defs++-- | TODO: derived properties+-- | TODO: instantiation of objs with (1) default values; (2) random sampling w.r.t. constraints+-- constructShape :: ShapeDef a -> [SampleRule] -> Shape a++canvasDims :: (Float, Float)+canvasDims = (-canvasHeight / 2, canvasHeight / 2)++-- TODO: change everything to camel case+x_sampler, y_sampler, pointSampler, width_sampler, height_sampler, angle_sampler, stroke_sampler, stroke_style_sampler, bool_sampler :: (Autofloat a) => SampledValue a+x_sampler = sampleFloatIn canvasDims+y_sampler = sampleFloatIn canvasDims+pointSampler = samplePointIn (canvasDims, canvasDims)+width_sampler = sampleFloatIn (3, canvasWidth / 6)+height_sampler = sampleFloatIn (3, canvasHeight / 6)+angle_sampler = sampleFloatIn (0, 360) -- TODO: check that frontend uses degrees, not radians+stroke_sampler = sampleFloatIn (0.5, 3)+stroke_style_sampler = sampleDiscrete [StrV "dashed", StrV "solid"]+bool_sampler = sampleDiscrete [BoolV True, BoolV False]++anchorPointType, circType, ellipseType, arrowType, braceType, curveType, lineType, rectType, squareType, parallelogramType, imageType, textType, arcType, rectTransformType, polygonType, circTransformType, curveTransformType, lineTransformType, squareTransformType, imageTransformType, ellipseTransformType, parallelogramTransformType, textTransformType :: (Autofloat a) => ShapeDef a++anchorPointType = ("AnchorPoint", M.fromList+ [+ -- ("x", (FloatT, x_sampler)),+ -- ("y", (FloatT, y_sampler)),+ ("location", (PtT, pointSampler)),+ ("name", (StrT, constValue $ StrV "defaultAnchorPoint"))+ ])++circType = ("Circle", M.fromList+ [+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("r", (FloatT, width_sampler)),+ ("strokeWidth", (FloatT, stroke_sampler)),+ ("style", (StrT, constValue $ StrV "filled")),+ ("strokeStyle", (StrT, constValue $ StrV "solid")),+ ("strokeColor", (ColorT, sampleColor)),+ ("color", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultCircle"))+ ])++ellipseType = ("Ellipse", M.fromList+ [+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("rx", (FloatT, width_sampler)),+ ("ry", (FloatT, height_sampler)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ ("stroke-width", (FloatT, stroke_sampler)),+ ("style", (StrT, sampleDiscrete [StrV "filled"])),+ ("stroke-style", (StrT, stroke_style_sampler)),+ ("color", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultEllipse"))+ ])++textType = ("Text", M.fromList+ [+ ("x", (FloatT, sampleFloatIn (-canvasWidth / 2, canvasWidth / 2))),+ ("y", (FloatT, sampleFloatIn (-canvasHeight / 2, canvasHeight / 2))),+ ("w", (FloatT, constValue $ FloatV 0)), -- NOTE: updated by front-end+ ("h", (FloatT, constValue $ FloatV 0)), -- NOTE: updated by front-end+ ("string", (StrT, constValue $ StrV "defaultLabelText")),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ ("style", (StrT, constValue $ StrV "none")),+ ("stroke", (StrT, constValue $ StrV "none")),+ ("color", (ColorT, constValue $ ColorV black)),+ ("name", (StrT, constValue $ StrV "defaultCircle"))+ ])++arrowType = ("Arrow", M.fromList+ [+ ("startX", (FloatT, x_sampler)),+ ("startY", (FloatT, y_sampler)),+ ("endX", (FloatT, x_sampler)),+ ("endY", (FloatT, y_sampler)),+ ("thickness", (FloatT, sampleFloatIn (5, 15))),+ ("style", (StrT, constValue $ StrV "straight")),+ ("color", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultArrow")),+ ("rotation", (FloatT, constValue $ FloatV 0.0))+ ])++braceType = ("Brace", M.fromList+ [+ ("startX", (FloatT, x_sampler)),+ ("startY", (FloatT, y_sampler)),+ ("endX", (FloatT, x_sampler)),+ ("endY", (FloatT, y_sampler)),+ ("color", (ColorT, sampleColor)),+ ("thickness", (FloatT, sampleFloatIn (1, 6))),+ ("name", (StrT, constValue $ StrV "defaultBrace"))+ ])++curveType = ("Curve", M.fromList+ [+ -- These two fields are for storage.+ ("path", (PtListT, constValue $ PtListV [])), -- TODO: sample path+ ("polyline", (PtListT, constValue $ PtListV [])), -- TODO: sample path+ -- The frontend only uses pathData to draw the curve.+ ("pathData", (PathDataT, constValue $ PathDataV [])), -- TODO: sample path+ ("strokeWidth", (FloatT, stroke_sampler)),+ ("style", (StrT, constValue $ StrV "solid")),+ ("fill", (ColorT, sampleColor)), -- for no fill, set opacity to 0+ ("color", (ColorT, sampleColor)),+ ("left-arrowhead", (BoolT, constValue $ BoolV False)),+ ("right-arrowhead", (BoolT, constValue $ BoolV False)),+ ("name", (StrT, constValue $ StrV "defaultCurve"))+ ])++lineType = ("Line", M.fromList+ [+ ("startX", (FloatT, x_sampler)),+ ("startY", (FloatT, y_sampler)),+ ("endX", (FloatT, x_sampler)),+ ("endY", (FloatT, y_sampler)),+ ("thickness", (FloatT, sampleFloatIn (5, 15))),++ ("left-arrowhead", (BoolT, constValue $ BoolV False)),+ ("right-arrowhead", (BoolT, constValue $ BoolV False)),+ ("color", (ColorT, sampleColor)),+ ("style", (StrT, constValue $ StrV "solid")),+ ("stroke", (StrT, constValue $ StrV "none")),+ ("name", (StrT, constValue $ StrV "defaultLine"))+ ])++rectType = ("Rectangle", M.fromList+ [+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("sizeX", (FloatT, width_sampler)),+ ("sizeY", (FloatT, height_sampler)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ ("color", (ColorT, sampleColor)),+ ("strokeWidth", (FloatT, stroke_sampler)),+ ("style", (StrT, constValue $ StrV "filled")),+ ("strokeColor", (ColorT, sampleColor)),+ ("strokeStyle", (StrT, constValue $ StrV "none")),+ ("name", (StrT, constValue $ StrV "defaultRect"))+ ])++squareType = ("Square", M.fromList+ [+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("side", (FloatT, width_sampler)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ -- TODO: distinguish between stroke color and fill color everywhere+ ("color", (ColorT, sampleColor)),+ ("style", (StrT, constValue $ StrV "none")), -- TODO: what is this?+ ("strokeColor", (ColorT, sampleColor)),+ ("strokeWidth", (FloatT, constValue $ FloatV 0.0)),+ ("name", (StrT, constValue $ StrV "defaultSquare"))+ ])++parallelogramType = ("Parallelogram", M.fromList+ [+ ("x", (FloatT, x_sampler)), -- (x, y) is the bottom-left corner of the parallelogram+ ("y", (FloatT, y_sampler)),+ ("lengthX", (FloatT, width_sampler)),+ ("lengthY", (FloatT, height_sampler)),+ ("angle", (FloatT, constValue $ FloatV 0.0)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ ("color", (ColorT, sampleColor)),+ ("stroke-style", (StrT, stroke_style_sampler)),+ ("stroke-color", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultParallelogram"))+ ])++imageType = ("Image", M.fromList+ [+ ("centerX", (FloatT, x_sampler)),+ ("centerY", (FloatT, y_sampler)),+ ("lengthX", (FloatT, width_sampler)),+ ("lengthY", (FloatT, height_sampler)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ ("style", (StrT, constValue $ StrV "none")),+ ("stroke", (StrT, constValue $ StrV "none")),+ ("path", (StrT, constValue $ StrV "missing image path")), -- Absolute path (URL)+ ("name", (StrT, constValue $ StrV "defaultImage"))+ ])++arcType = ("Arc", M.fromList+ [+ ("x", (FloatT, x_sampler)), -- x,y are the cordinates for the bottom left position+ ("y", (FloatT, y_sampler)), -- of the right angle or the midlle pos of a regular angle+ ("r", (FloatT, width_sampler)),+ ("size", (FloatT, width_sampler)),+ ("lengthX", (FloatT, width_sampler)),+ ("lengthY", (FloatT, height_sampler)),+ ("angle", (FloatT, angle_sampler)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),++ ("isRight", (BoolT, bool_sampler)), -- This property overrides the angle property++ ("strokeWidth", (FloatT, constValue $ FloatV 1.0)),+ ("strokeColor", (ColorT, sampleColor)),+ ("fillColor", (ColorT, sampleColor)),+ ("left-arrowhead", (BoolT, constValue $ BoolV False)),+ ("right-arrowhead", (BoolT, constValue $ BoolV False)),++ ("name", (StrT, constValue $ StrV "defaultArc"))+ ])++rectTransformType = ("RectangleTransform", M.fromList+ [+ -- These attributes serve as DOF in the default transformation+ -- They are NOT the final x, etc.+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("sizeX", (FloatT, width_sampler)),+ ("sizeY", (FloatT, height_sampler)),+ ("rotation", (FloatT, angle_sampler)),++ ("transform", (FloatT, constValue $ HMatrixV idH)), -- Set in Style+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed++ -- TODO compute these+ -- ("finalX", (FloatT, constValue $ FloatV 0.0)),+ -- ("finalY", (FloatT, constValue $ FloatV 0.0)),+ -- ("finalSizeX", (FloatT, constValue $ FloatV 1.0)),+ -- ("finalSizeY", (FloatT, constValue $ FloatV 1.0)),+ -- ("finalRotation", (FloatT, constValue $ FloatV 0.0)),++ ("color", (ColorT, sampleColor)),+ ("strokeWidth", (FloatT, stroke_sampler)),+ ("style", (StrT, constValue $ StrV "filled")),+ ("strokeColor", (ColorT, sampleColor)),+ ("strokeStyle", (StrT, constValue $ StrV "none")),+ ("name", (StrT, constValue $ StrV "defaultRect")),+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly))+ ])++-- Also using the new transforms+polygonType = ("Polygon", M.fromList+ [+ ("points", (PtListT, constValue $ PtListV testTriangle)),+ ("polygon", (PtListT, constValue $ PtListV [])),++ -- These attributes serve as DOF in the default transformation+ -- They are NOT the final x, etc.+ -- TODO: should these be sampled?+ ("dx", (FloatT, x_sampler)), -- Polygon doesn't have a natural "center"+ ("dy", (FloatT, y_sampler)),+ ("scaleX", (FloatT, width_sampler)),+ ("scaleY", (FloatT, height_sampler)),+ ("rotation", (FloatT, angle_sampler)),+ -- TODO: currently rotates about the center of the Penrose canvas, (0, 0)++ ("centerX", (FloatT, constValue $ FloatV 0.0)),+ ("centerY", (FloatT, constValue $ FloatV 0.0)),++ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed++ ("strokeWidth", (FloatT, stroke_sampler)),+ ("strokeStyle", (StrT, constValue $ StrV "solid")),+ ("strokeColor", (ColorT, sampleColor)),++ ("fillColor", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultPolygon"))+ ])++circTransformType = ("CircleTransform", M.fromList+ [+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("r", (FloatT, width_sampler)),+ -- TODO: circle currently has rotations hardcoded to 0.0 (since we aren't yet rotating about a point)++ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly)),++ ("strokeWidth", (FloatT, stroke_sampler)),+ ("style", (StrT, constValue $ StrV "filled")),+ ("strokeStyle", (StrT, constValue $ StrV "solid")),+ ("strokeColor", (ColorT, sampleColor)),+ ("color", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultCircle"))+ ])++curveTransformType = ("CurveTransform", M.fromList+ [+ ("dx", (FloatT, constValue $ FloatV 0.0)), -- Curve doesn't have a natural "center"+ ("dy", (FloatT, constValue $ FloatV 0.0)),+ ("scaleX", (FloatT, constValue $ FloatV 1.0)),+ ("scaleY", (FloatT, constValue $ FloatV 1.0)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ -- TODO: currently rotates about the center of the Penrose canvas, (0, 0)++ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly)),+ + ("path", (PtListT, constValue $ PtListV [])), -- TODO: sample path+ ("polyline", (PtListT, constValue $ PtListV [])), -- TODO: sample path+ ("pathData", (PathDataT, constValue $ PathDataV [])), -- TODO: sample path+ ("strokeWidth", (FloatT, stroke_sampler)),+ ("style", (StrT, constValue $ StrV "solid")),+ ("fill", (ColorT, sampleColor)), -- for no fill, set opacity to 0+ ("color", (ColorT, sampleColor)),+ ("left-arrowhead", (BoolT, constValue $ BoolV False)),+ ("right-arrowhead", (BoolT, constValue $ BoolV False)),+ ("name", (StrT, constValue $ StrV "defaultCurve"))+ ])++-- If the start and end are not set, by default, it's a unit line segment aligned w/ x-axis, centered at origin.+-- If the start and end are set in Style, then that will be the line segment to which all subsequent transforms apply.+lineTransformType = ("LineTransform", M.fromList+ [+ ("startX", (FloatT, constValue $ FloatV $ -0.5)),+ ("startY", (FloatT, constValue $ FloatV 0)),+ ("endX", (FloatT, constValue $ FloatV 0.5)),+ ("endY", (FloatT, constValue $ FloatV 0.0)),++ -- By default, this is NOT set. Should it be?+ ("dx", (FloatT, constValue $ FloatV 0.0)), -- Curve doesn't have a natural "center"+ ("dy", (FloatT, constValue $ FloatV 0.0)),+ ("scaleX", (FloatT, constValue $ FloatV 1.0)),+ ("scaleY", (FloatT, constValue $ FloatV 1.0)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),+ -- TODO: currently rotates about the center of the Penrose canvas, (0, 0)++ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly)),++ ("left-arrowhead", (BoolT, constValue $ BoolV False)),+ ("right-arrowhead", (BoolT, constValue $ BoolV False)),++ ("thickness", (FloatT, sampleFloatIn (5, 15))),+ ("color", (ColorT, sampleColor)),+ ("style", (StrT, constValue $ StrV "solid")),+ ("stroke", (StrT, constValue $ StrV "none")),+ ("name", (StrT, constValue $ StrV "defaultLine"))+ ])++squareTransformType = ("SquareTransform", M.fromList+ [+ ("x", (FloatT, x_sampler)), -- x and y as dx and dy in transform?+ ("y", (FloatT, y_sampler)),+ ("side", (FloatT, width_sampler)), -- as both scaleX and scaleY ? + ("rotation", (FloatT, constValue $ FloatV 0.0)), -- initialize as 0?+ -- matrices+ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)),+ -- ones that remain the same+ ("color", (ColorT, sampleColor)),+ ("style", (StrT, constValue $ StrV "none")),+ ("strokeColor", (ColorT, sampleColor)),+ ("strokeWidth", (FloatT, constValue $ FloatV 0.0)),+ ("name", (StrT, constValue $ StrV "defaultSquare")),+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly))+ ])++imageTransformType = ("ImageTransform", M.fromList+ [+ ("centerX", (FloatT, x_sampler)),+ ("centerY", (FloatT, y_sampler)),++ ("initWidth", (FloatT, constValue $ FloatV 0.0)), -- Set by frontend+ ("initHeight", (FloatT, constValue $ FloatV 0.0)), -- (same)++ ("scaleX", (FloatT, constValue $ FloatV 1.0)), -- set by image file?+ ("scaleY", (FloatT, constValue $ FloatV 1.0)), + ("rotation", (FloatT, constValue $ FloatV 0.0)),+ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)),++ ("style", (StrT, constValue $ StrV "none")),+ ("stroke", (StrT, constValue $ StrV "none")),+ ("path", (StrT, constValue $ StrV "missing image path")), -- Absolute path (URL)+ ("name", (StrT, constValue $ StrV "defaultImage")),+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly))+ ])++ellipseTransformType = ("EllipseTransform", M.fromList+ [+ ("x", (FloatT, x_sampler)), --dx+ ("y", (FloatT, y_sampler)), --dy+ ("rx", (FloatT, width_sampler)), --sx+ ("ry", (FloatT, height_sampler)), --sy+ ("rotation", (FloatT, constValue $ FloatV 0.0)), --rot+ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)),+ ("stroke-width", (FloatT, stroke_sampler)),+ ("style", (StrT, sampleDiscrete [StrV "filled"])),+ ("stroke-style", (StrT, stroke_style_sampler)),+ ("color", (ColorT, sampleColor)),+ ("name", (StrT, constValue $ StrV "defaultEllipse")),+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly))+ ])++-- Starting with a square centered at origin, we apply this transformation:+-- (in T1 then T2 format)+-- scale by (lengthX, lengthY)+-- shear X by lambda = f(angle in radians) = 1 / tan(angle)+-- rotate by angle+-- translate by (x, y)+parallelogramTransformType = ("ParallelogramTransform", M.fromList+ [+ ("x", (FloatT, x_sampler)), -- (x, y) is the CENTER of the parallelogram+ ("y", (FloatT, y_sampler)),+ ("width", (FloatT, width_sampler)), -- width of the rectangle pre-shear+ ("height", (FloatT, height_sampler)), -- height of the rectangle pre-shear+ ("innerAngle", (FloatT, constValue $ FloatV (pi/3))), -- shear angle of the rectangle+ ("rotation", (FloatT, constValue $ FloatV 0.0)), -- about the origin++ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly)),+ + ("color", (ColorT, sampleColor)),+ ("strokeStyle", (StrT, stroke_style_sampler)),+ ("strokeColor", (ColorT, sampleColor)),+ ("strokeWidth", (FloatT, constValue $ FloatV 0.0)),+ ("name", (StrT, constValue $ StrV "defaultParallelogram"))+ ])++textTransformType = ("TextTransform", M.fromList+ [+ ("x", (FloatT, x_sampler)),+ ("y", (FloatT, y_sampler)),+ ("scaleX", (FloatT, constValue $ FloatV 1.0)), -- TODO: set text size in points+ ("scaleY", (FloatT, constValue $ FloatV 1.0)),+ ("rotation", (FloatT, constValue $ FloatV 0.0)),++ ("w", (FloatT, constValue $ FloatV 0)), -- NOTE: updated by front-end+ ("h", (FloatT, constValue $ FloatV 0)), -- NOTE: updated by front-end+ ("path", (PathDataT, constValue $ PathDataV [])), -- NOTE: updated by front-end++ -- NOTE: the polygon will only show up after a few steps, since we have to wait for the server to set the width/height/path+ ("transform", (FloatT, constValue $ HMatrixV idH)),+ ("transformation", (FloatT, constValue $ HMatrixV idH)), -- Computed+ ("polygon", (PolygonT, constValue $ PolygonV emptyPoly)),++ ("string", (StrT, constValue $ StrV "defaultLabelTextTransform")),+ ("style", (StrT, constValue $ StrV "none")),+ ("stroke", (StrT, constValue $ StrV "none")),+ ("color", (ColorT, constValue $ ColorV black)),+ ("name", (StrT, constValue $ StrV "defaultCircle"))+ ])++-----++exampleCirc :: (Autofloat a) => Shape a+exampleCirc = ("Circle", M.fromList+ [+ ("x", FloatV 5.5),+ ("y", FloatV 100.2),+ ("r", FloatV 5),+ ("name", StrV "exampleCirc"),+ ("style", StyleV "filled"),+ ("color", ColorV black)+ ])++--------------------------------------------------------------------------------+-- Parser for shape def DSL (TODO)++--------------------------------------------------------------------------------+-- Type checker for a particular shape instance against its def (TODO)+--+-- checkShape :: (Autofloat a) => Shape a -> ShapeDef a -> Shape a+-- checkShape shape def =++--------------------------------------------------------------------------------+-- Utility functions for Runtime++-- | given a translation generated by the Style compiler, generate all GPIs+-- NOTE: equilavant to genAllObjs+-- generateShapes :: (Autofloat a) => Translation a -> [Shape a]+-- COMBAK:+-- - where to define default objs such as sizeFuncs?+-- - do we allow extended properties? If so, where do we resolve them?+-- generateShapes trans = []+ -- TODO write out full procedure++findShape :: (Autofloat a) => String -> [Shape a] -> Shape a+findShape shapeName shapes =+ case filter (\s -> getName s == shapeName) shapes of+ [x] -> x+ _ -> error ("findShape: expected one shape for \"" ++ shapeName ++ "\", but did not find just one (returned zero or many).")++-- TODO: can use alter, update, adjust here. Come back if performance matters+-- | Setting the value of a property+set :: (Autofloat a) => Shape a -> PropID -> Value a -> Shape a+set (t, propDict) prop val = case M.lookup prop propDict of+ Nothing -> noPropError "set" prop t+ _ -> (t, M.update (const $ Just val) prop propDict)++-- | Getting the value of a property+get :: (Autofloat a) => Shape a -> PropID -> Value a+get (t, propDict) prop = fromMaybe+ (noPropError "get" prop t)+ (M.lookup prop propDict)+{-# INLINE get #-}++-- | batch get+getAll :: (Autofloat a) => Shape a -> [PropID] -> [Value a]+getAll shape = map (get shape)++-- | batch set+setAll :: (Autofloat a) => Shape a -> [(PropID, Value a)] -> Shape a+setAll = foldl' (\s (k, v) -> set s k v)+++-- | reset a property to its default value+-- TODO: now needs to take in a random generator+-- reset :: (Autofloat a) => Shape a -> PropID -> Shape a+-- reset (t, propDict) prop =+-- let val = defaultValueOf prop $ findDef t shapeDefs+-- in (t, M.update (const $ Just val) prop propDict)++-- | whether a shape has a prop+hasProperty :: (Autofloat a) => Shape a -> PropID -> Bool+hasProperty (t, propDict) prop = M.member prop propDict++-- | given name of prop, return type+typeOfProperty :: (Autofloat a) => PropID -> Shape a -> ValueType+typeOfProperty prop (t, propDict) = case M.lookup prop propDict of+ Nothing -> noPropError "typeOfProperty" prop t+ Just v -> typeOf v++-- | property IDs in alphabetical order+propertyIDs :: (Autofloat a) => Shape a -> [PropID]+propertyIDs (_, propDict) = map fst $ M.toAscList propDict++-- | vals in alphabetical order of their keys+propertyVals :: (Autofloat a) => Shape a -> [Value a]+propertyVals (_, propDict) = map snd $ M.toAscList propDict++--------------------------------------------------------------------------------+-- Utility functions for objective/constraint function writers++-- | 'is' checks whether a shape is of a certain type+is :: (Autofloat a) => Shape a -> ShapeTypeStr -> Bool+is (t1, _) t2 = t1 == t2++-- | short-hand for 'get'+(.:) :: (Autofloat a) => Shape a -> PropID -> Value a+(.:) = get+{-# INLINE (.:) #-}++getX, getY :: (Autofloat a) => Shape a -> a+getX shape = case shape .: "x" of+ FloatV x -> x+ _ -> error "getX: expected float but got something else"+getY shape = case shape .: "y" of+ FloatV y -> y+ _ -> error "getY: expected float but got something else"++getPoint :: (Autofloat a) => String -> Shape a -> (a, a)+getPoint "start" shape = case (shape .: "startX", shape .: "startY") of+ (FloatV x, FloatV y) -> (x, y)+ _ -> error "getPoint expected two floats but got something else"+getPoint "end" shape = case (shape .: "endX", shape .: "endY") of+ (FloatV x, FloatV y) -> (x, y)+ _ -> error "getPoint expected two floats but got something else"+getPoint _ shape = error "getPoint did not receive existing property name"++-- To use with vector operations+getPointV :: (Autofloat a) => String -> Shape a -> [a]+getPointV "start" shape = case (shape .: "startX", shape .: "startY") of+ (FloatV x, FloatV y) -> [x, y]+ _ -> error "getPointV expected two floats but got something else"+getPointV "end" shape = case (shape .: "endX", shape .: "endY") of+ (FloatV x, FloatV y) -> [x, y]+ _ -> error "getPointV expected two floats but got something else"+getPointV _ shape = error "getPointV did not receive existing property name"++getName :: (Autofloat a) => Shape a -> String+getName shape = case shape .: "name" of+ StrV s -> s+ _ -> error "getName: expected string but got something else"++setName :: (Autofloat a) => String -> Shape a -> Shape a+setName v shape = set shape "name" (StrV v)++setX, setY :: (Autofloat a) => Value a -> Shape a -> Shape a+setX v shape@("Arrow", _) = set shape "startX" v+setX v shape = set shape "x" v++setY v shape@("Arrow", _) = set shape "startY" v+setY v shape = set shape "y" v++getNum :: (Autofloat a) => Shape a -> PropID -> a+getNum shape prop = case shape .: prop of+ FloatV x -> x+ res -> error ("getNum: expected float but got something else: " ++ show res)++getPoints :: (Autofloat a) => Shape a -> [Pt2 a]+getPoints shape = case shape .: "points" of+ PtListV x -> x+ _ -> error "getPoints: expected [(Float, Float)] but got something else"++getPolygon :: (Autofloat a) => Shape a -> Polygon a+getPolygon shape = case shape .: "polygon" of+ PolygonV x -> x+ _ -> error "getPolygon: expected [(Float, Float)] but got something else"++getPath :: (Autofloat a) => Shape a -> [Pt2 a]+getPath shape = case shape .: "path" of+ PtListV x -> x+ _ -> error "getPath: expected [(Float, Float)] but got something else"++getPathData :: (Autofloat a) => Shape a -> PathData a+getPathData shape = case shape .: "pathData" of+ PathDataV x -> x+ _ -> error "getPathData: expected [PathData a] but got something else"++-- | Apply a function to each point in a path+mapPathData :: (Autofloat a) => (Pt2 a -> Pt2 a) -> PathData a -> PathData a+mapPathData f pd = map (mapPath f) pd++mapPath :: (Autofloat a) => (Pt2 a -> Pt2 a) -> Path' a -> Path' a+mapPath f (Closed es) = Closed $ map (mapElem f) es+mapPath f (Open es) = Open $ map (mapElem f) es++mapElem :: (Autofloat a) => (Pt2 a -> Pt2 a) -> Elem a -> Elem a+mapElem f (Pt p) = Pt $ f p+mapElem f (CubicBez (p0, p1, p2)) = CubicBez (f p0, f p1, f p2)+mapElem f (CubicBezJoin (p0, p1)) = CubicBezJoin (f p0, f p1)+mapElem f (QuadBez (p0, p1)) = QuadBez (f p0, f p1)+mapElem f (QuadBezJoin p) = QuadBezJoin $ f p++-- | Add an offset to each point in a path+translatePath :: (Autofloat a) => Pt2 a -> PathData a -> PathData a+translatePath offset pd = mapPathData (+: offset) pd++-- | Figure out whether to translate pathManual or pathData+movePath :: (Autofloat a) => (a, a) -> Shape a -> Shape a+movePath offset shape =+ let pathManual = getPath shape+ pathData = getPathData shape in+ case (pathManual, pathData) of+ (_:_, []) -> let res = (map (+: offset) pathManual) in+ set shape "path" (PtListV res)+ ([], _:_) -> let res = translatePath offset pathData in+ set shape "pathData" (PathDataV res)+ (_:_, _:_) -> error "shape can't have both path manually set and path data"+ ([], []) -> error "shape has no path or data"++-- | Transform utils+getTransform :: (Autofloat a) => Shape a -> HMatrix a+getTransform shape = case shape .: "transform" of+ HMatrixV x -> x+ _ -> error "getTransform: expected HMatrix but got something else"++getTransformation :: (Autofloat a) => Shape a -> HMatrix a+getTransformation shape = case shape .: "transformation" of+ HMatrixV x -> x+ _ -> error "getTransformation: expected HMatrix but got something else"++-- | ternary op for set (TODO: maybe later)+-- https://wiki.haskell.org/Ternary_operator++-- | HACK: returns true of a property of a shape is not supposed to be+-- | changed by the optimizer+isPending :: ShapeTypeStr -> PropID -> Bool+isPending typ propId = propId `elem` pendingProperties typ++-- | HACK: returns all "pending" properties that are undeterminded until+-- | rendered by the frontend+pendingProperties :: ShapeTypeStr -> [PropID]+pendingProperties "Text" = ["w", "h"]+pendingProperties "TextTransform" = ["w", "h"]+pendingProperties "ImageTransform" = ["initWidth", "initHeight"]+pendingProperties _ = []++-- | Given 'ValueType' and 'ShapeTypeStr', return all props of that ValueType+propertiesOf :: ValueType -> ShapeTypeStr -> [PropID]+propertiesOf propType shapeType =+ M.keys $ M.filter (\(t, _) -> t == propType) $ snd $ findDef shapeType++-- | Given 'ValueType' and 'ShapeTypeStr', return all props NOT of that ValueType+propertiesNotOf :: ValueType -> ShapeTypeStr -> [PropID]+propertiesNotOf propType shapeType =+ M.keys $ M.filter (\(t, _) -> t /= propType) $ snd $ findDef shapeType++-- filterProperties :: (Autofloat a) => ((ValueType, SampledValue a) -> Bool) -> [PropID]+-- filterProperties filterF =++-- | Map over all properties of a shape+-- TODO: withKey?+mapProperties :: (Autofloat a) => (Value a -> Value a) -> Shape a -> Shape a+mapProperties f (t, propDict) = (t, M.map f propDict)++-- | fold over all properties of a shape+-- TODO: withKey?+foldlProperties :: (Autofloat a) => (b -> Value a -> b) -> b -> Shape a -> b+foldlProperties f accum (_, propDict) = M.foldl' f accum propDict++foldlPropertyDefs :: (Autofloat a) => (b -> (ValueType, SampledValue a) -> b) -> b -> ShapeDef a -> b+foldlPropertyDefs f accum (_, propDict) = M.foldl' f accum propDict++foldlPropertyMappings :: (Autofloat a) =>+ (b -> PropID -> (ValueType, SampledValue a) -> b) -> b -> ShapeDef a -> b+foldlPropertyMappings f accum (_, propDict) = M.foldlWithKey f accum propDict++--------------------------------------------------------------------------------+-- Error Msgs++noShapeError functionName shapeType =+ error (functionName ++ ": Shape \"" ++ shapeType ++ "\" does not exist")+noPropError functionName prop shapeType =+ error (functionName ++ ": Property \"" ++ prop +++ "\" does not exist in shape \"" ++ shapeType ++ "\"")+++--------------------------------------------------------------------------------+-- Color definition+-- Adopted from gloss: https://github.com/benl23x5/gloss/blob/c63daedfe3b60085f8a9e810e1389cbc29110eea/gloss-rendering/Graphics/Gloss/Internals/Data/Color.hs++data Color+ -- | Holds the color components. All components lie in the range [0..1.+ = RGBA !Float !Float !Float !Float+ deriving (Show, Eq, Generic)+instance ToJSON Color+instance FromJSON Color++-- | Make a custom color. All components are clamped to the range [0..1].+makeColor :: Float -- ^ Red component.+ -> Float -- ^ Green component.+ -> Float -- ^ Blue component.+ -> Float -- ^ Alpha component.+ -> Color+makeColor r g b a+ = clampColor+ $ RGBA r g b a+{-# INLINE makeColor #-}++-- | Take the RGBA components of a color.+rgbaOfColor :: Color -> (Float, Float, Float, Float)+rgbaOfColor (RGBA r g b a) = (r, g, b, a)+{-# INLINE rgbaOfColor #-}++-- | Clamp components of a raw color into the required range.+clampColor :: Color -> Color+clampColor cc+ = let (r, g, b, a) = rgbaOfColor cc+ in RGBA (min 1 r) (min 1 g) (min 1 b) (min 1 a)++black, white :: Color+black = makeColor 0.0 0.0 0.0 1.0+white = makeColor 1.0 1.0 1.0 1.0++makeColor' :: (Autofloat a) => a -> a -> a -> a -> Color+makeColor' r g b a = makeColor (r2f r) (r2f g) (r2f b) (r2f a)++--------------------------------------------------------------------------------+-- Approximating a Bezier curve via polygon or bbox++-- | Polygonize path by extruding the polyline to account for thickness and adding any arrowheads, if present.+-- For each point, find the corresponding inner and outer points on the extruded line+-- by taking the tangent and then taking the inner and outer normal+-- Note: not good for steep angles!+-- Then make the polygon by joining the points in order, accounting for arrowheads++-- TODO: (performance optimization) remove the ++, the accesses to last of list, and the reverses++polygonizePathPolygon :: Autofloat a => Int -> a -> Bool -> Bool -> PathData a -> [Pt2 a]+polygonizePathPolygon n thickness leftArr rightArr p = + let polyline = removeClosePoints $ polygonizePath n p+ tangents = map calcTangent $ zip polyline (tail polyline)+ tangentsWithLast = tangents ++ [last tangents] -- use the same tangent for the last point+ -- outer and inner are two "copies" of the polyline, offset in the +/- normal directions+ (outer, inner) = unzip $ map (extrude thickness) $ zip polyline tangentsWithLast+ snipSize = 4 * thickness + -- snipSize is the amount to remove from the polygonized curve to attach the arrows at either end++ (ltArrow, outer', inner') = + if not leftArr then ([], outer, inner)+ else let ltCenter = head polyline+ ltAngle = atan2' $ head tangents+ ltTransform = translationM ltCenter # rotationM ltAngle+ ltArrow = transformSimplePoly ltTransform $ ltArrowheadPoly thickness+ (outerFirst, innerFirst) = (head outer, head inner)+ outer' = dropWhile (\x -> mag (x -: outerFirst) < snipSize) outer+ inner' = dropWhile (\x -> mag (x -: innerFirst) < snipSize) inner+ in (ltArrow, outer', inner')++ (rtArrow, outer'', inner'') = + if not rightArr then ([], outer', inner') + else let rtCenter = last polyline+ rtAngle = atan2' $ last tangents+ rtTransform = translationM rtCenter # rotationM rtAngle+ rtArrow = transformSimplePoly rtTransform $ rtArrowheadPoly thickness+ (outerLast, innerLast) = (last outer, last inner)+ outer'' = reverse $ dropWhile (\x -> mag (x -: outerLast) < snipSize) $ reverse outer'+ inner'' = reverse $ dropWhile (\x -> mag (x -: innerLast) < snipSize) $ reverse inner'+ in (rtArrow, outer'', inner'')++ polygonWithArrows = outer'' ++ rtArrow ++ reverse inner'' ++ ltArrow++ in polygonWithArrows++ where atan2' (x, y) = atan2 y x++ removeClosePoints :: (Autofloat a) => [Pt2 a] -> [Pt2 a]+ -- Heuristic: if any two points are too close together, remove the first one+ -- Not super principled but just to make sure that the tangents don't NaN if two points are too close+ removeClosePoints ps = let ptsWithNext = zip ps (tail ps) in+ (map fst $ filter (\(p1, p2) -> mag (p2 -: p1) >= epsp) ptsWithNext) ++ [last ps]+ where epsp = 10 ** (-8)++ calcTangent :: (Autofloat a) => (Pt2 a, Pt2 a) -> Pt2 a+ calcTangent (start, end) = normalize' $ end -: start++ extrude :: (Autofloat a) => a -> (Pt2 a, Pt2 a) -> (Pt2 a, Pt2 a)+ extrude thickness (base, tangent) = + let normal = thickness / 2.0 *: rot90 tangent in+ (base +: normal, base -: normal)++-- | Polygonize path as polyline+polygonizePath :: Autofloat a => Int -> PathData a -> [Pt2 a]+polygonizePath n p = case polygonize n p of+ [] -> error "empty curve: did you set the pathdata or path?"+ x:xs -> x -- What are the other parts of this list?++polygonize :: Autofloat a => Int -> PathData a -> [[Pt2 a]]+polygonize maxIter = map go+ where+ go (Closed path) = error "TODO"+ go (Open path) = concatMap (polyCubicBez 0 maxIter) $ expandCurves path++type CubicBezCoeffs a = (Pt2 a, Pt2 a, Pt2 a, Pt2 a)++expandCurves :: Autofloat a => [Elem a] -> [CubicBezCoeffs a]+expandCurves elems = zipWith attach elems $ tail elems+ where+ attach (Pt a) (CubicBez (b, c, d)) = (a, b, c, d)+ attach (CubicBez (_, _, a)) (CubicBez (b, c, d)) = (a, b, c, d)++-- | implements http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.86.162&rep=rep1&type=pdf+polyCubicBez :: Autofloat a => Int -> Int -> CubicBezCoeffs a -> [Pt2 a]+polyCubicBez count maxCount curve@(a, b, c, d) =+ if (tr "count" count) >= maxCount then [a, b, c, d] else+ concatMapTuple (polyCubicBez (count + 1) maxCount) $ divideCubicBezier curve+ where concatMapTuple f (a1, a2) = f a1 ++ f a2++isFlat :: Autofloat a => CubicBezCoeffs a -> Bool+isFlat (a, b, c, d) = True++divideCubicBezier :: Autofloat a => CubicBezCoeffs a -> (CubicBezCoeffs a, CubicBezCoeffs a)+divideCubicBezier bezier@(a, _, _, d) = (left, right) where+ left = (a, ab, abbc, abbcbccd)+ right = (abbcbccd, bccd, cd, d)+ (ab, _bc, cd, abbc, bccd, abbcbccd) = splitCubicBezier bezier++-- BC+-- B X----------X---------X C+-- ^ / ___/ \___ \ ^+-- u \ / __X------X------X_ \ / v+-- \ /___/ ABBC BCCD \___\ /+-- AB X/ \X CD+-- / \+-- / \+-- / \+-- A X X D+splitCubicBezier :: Autofloat a => CubicBezCoeffs a -> (Pt2 a, Pt2 a, Pt2 a, Pt2 a, Pt2 a, Pt2 a)+splitCubicBezier (a, b, c, d) = (ab, bc, cd, abbc, bccd, abbcbccd)+ where+ ab = a `midpoint` b+ bc = b `midpoint` c+ cd = c `midpoint` d+ abbc = ab `midpoint` bc+ bccd = bc `midpoint` cd+ abbcbccd = abbc `midpoint` bccd++bezierBbox :: (Autofloat a) => Shape a -> ((a, a), (a, a)) -- poly Point type?+bezierBbox cb = let path = getPath cb+ (xs, ys) = (map fst path, map snd path)+ lower_left = (minimum xs, minimum ys)+ top_right = (maximum xs, maximum ys) in+ (lower_left, top_right)++--------------------------------------------------------------------------------+-- DEBUG: main function to test out the module+--+-- main :: IO ()+-- main = do+-- let c = exampleCirc+-- print $ c .: "r"+-- let c' = set c "r" (FloatV 20)+-- print c'+-- let c'' = reset c "r"+-- print c''+-- print $ propertiesOf FloatT "Circle" shapeDefs
− src/StyAst.hs
@@ -1,421 +0,0 @@-module StyAst where--- module Main (main) where--import Control.Monad (void)-import Text.Megaparsec-import Text.Megaparsec.Expr-import Text.Megaparsec.String -- input stream is of the type ‘String’-import System.Environment-import qualified Data.Map.Strict as M-import qualified Text.Megaparsec.Lexer as L----- Style grammar (relies on the Substance grammar, specifically SubObj)--data SubType = Set | Pt | Map | Intersect | NoIntersect | NoSubset | Subset | PointIn | PointNotIn | AllTypes deriving (Show, Eq)--data StyObj = Circle | Box | Dot | Arrow | NoShape | Color | Text | Auto- deriving (Show)--type StyObjInfo- = (StyObj, M.Map String Expr)--data StySpec = StySpec {- spType :: SubType,- spId :: String,- spArgs :: [String],- spShape :: StyObjInfo,- spShpMap :: M.Map String StyObjInfo-} deriving (Show)--type StyProg = [Block]--type Block = ([Selector], [Stmt])--data Selector = Selector- { selTyp :: SubType- , selPatterns :: [Pattern]- -- , selIds :: [String]- }- deriving (Show)-data Pattern- = RawID String- | WildCard String- deriving (Show)--data Stmt- = Assign String Expr- | ObjFn String [Expr]- | ConstrFn String [Expr]- | Avoid String [Expr]- deriving (Show)--data Expr- = IntLit Integer- | FloatLit Float- | Id String- | BinOp BinaryOp Expr Expr- | Cons StyObj [Stmt] -- Constructors for objects- deriving (Show)--data BinaryOp = Access deriving (Show)--data Color = RndColor | Colo- { r :: Float- , g :: Float- , b :: Float- , a :: Float }- deriving (Show)------ data Shape--- = Circle [(String, Expr)]--- | Box [(String, Expr)]--- | Dot [(String, Expr)]--- | Arrow [(String, Expr)]--- | NoShape--- deriving (Show)------ Style program-styleParser :: Parser [Block]-styleParser = between sc eof styProg---- TODO: required global and/or style block or not?--- TODO: How can I write something like noop???--- NOTE: sequence matters here-styProg :: Parser [Block]-styProg = some block--- globalBlock <|> typeBlock <|> objBlock--- <|> emptyProg------ Style blocks-block :: Parser Block-block = do- sel <- selector `sepBy1` comma- void (symbol "{")- try newline'- sc- stmts <- try stmtSeq- -- res <- try stmtSeq- -- let stmts = case res of- -- Just a -> a- -- Nothing -> []- void (symbol "}")- newline'- return (sel, stmts)- -- return (sel, [])--globalSelect :: Parser Selector-globalSelect = do- i <- WildCard <$> identifier- -- return $ Selector AllTypes [] []- return $ Selector AllTypes [i]--constructorSelect :: Parser Selector-constructorSelect = do- typ <- subtype- -- sc- pat <- patterns- -- void sc <|> void (symbol ":")- -- ids <- many identifier- -- res <- optional $ rword "as" *> some identifier- -- let ids = case res of- -- Just a -> a- -- Nothing -> []- -- return $ Selector typ pat ids- return $ Selector typ pat--selector :: Parser Selector-selector = constructorSelect <|> globalSelect--subtype :: Parser SubType-subtype = do- str <- symbol "Set"- <|> symbol "Point"- <|> symbol "Map"- <|> symbol "Subset"- <|> symbol "NoSubset"- <|> symbol "Intersect"- <|> symbol "NoIntersect"- <|> symbol "PointIn"- <|> symbol "PointNotIn"-- return (convert str)- where convert s- | s == "Set" = Set- | s == "Point" = Pt- | s == "Map" = Map- | s == "Subset" = Subset- | s == "NoSubset" = NoSubset- | s == "Intersect" = Intersect- | s == "NoIntersect" = NoIntersect- | s == "PointIn" = PointIn- | s == "PointNotIn" = PointNotIn--styObj :: Parser StyObj-styObj = do- str <- symbol "Color"- <|> symbol "None"- <|> symbol "Arrow"- <|> symbol "Text"- <|> symbol "Circle"- <|> symbol "Box"- <|> symbol "Dot"- return (convert str)- where convert s- | s == "Color" = Color- | s == "Arrow" = Arrow- | s == "None" = NoShape- | s == "Text" = Text- | s == "Circle" = Circle- | s == "Box" = Box- | s == "Dot" = Dot--patterns :: Parser [Pattern]-patterns = many pattern- where pattern = (WildCard <$> identifier <|> RawID <$> backticks identifier)-- -- manyTill anyChar (symbol "{")----- Statements-stmtSeq :: Parser [Stmt]-stmtSeq = endBy stmt newline'--stmt :: Parser Stmt-stmt =- try objFn- <|> try assignStmt- <|> try avoidObjFn- <|> try constrFn----assignStmt :: Parser Stmt-assignStmt = do- var <- attribute- sc- void (symbol "=")- e <- expr- return (Assign var e)----objFn :: Parser Stmt-objFn = do- rword "objective"- fname <- identifier- void (symbol "(")- params <- expr `sepBy` comma- void (symbol ")")- -- params <- sepBy expr comma- return (ObjFn fname params)--avoidObjFn :: Parser Stmt-avoidObjFn = do- rword "avoid"- fname <- identifier- lbrac- params <- expr `sepBy` comma- rbrac- return (Avoid fname params)--constrFn :: Parser Stmt-constrFn = do- rword "constraint"- fname <- identifier- void (symbol "(")- params <- expr `sepBy` comma- void (symbol ")")- -- params <- sepBy expr comma- return (ConstrFn fname params)--expr :: Parser Expr-expr = try objConstructor- <|> makeExprParser term operators- <|> none- <|> auto- <|> number--term :: Parser Expr-term = Id <$> identifier--operators :: [[Operator Parser Expr]]-operators = [ [ InfixL (BinOp Access <$ symbol ".")] ]--none :: Parser Expr-none = do- rword "None"- return $ Cons NoShape []--auto :: Parser Expr-auto = do- rword "Auto"- return $ Cons Auto []--objConstructor :: Parser Expr-objConstructor = do- typ <- styObj- lbrac >> newline'- stmts <- stmtSeq- rbrac -- NOTE: not consuming the space because stmt already does- return $ Cons typ stmts--number :: Parser Expr-number = FloatLit <$> try float <|> IntLit <$> integer--attribute :: Parser String-attribute = many alphaNumChar------------- typeBlock :: Parser Block--- typeBlock = do--- t <- typ--- stmts <- braces stmtSeq--- return $ TypeBlock t stmts------ objBlock :: Parser Block--- objBlock = do--- i <- identifier--- stmts <- braces stmtSeq--- return $ ObjBlock i stmts------- Lexer functions-sc :: Parser ()-sc = L.space (void separatorChar) lineCmnt blockCmnt- where lineCmnt = L.skipLineComment "--" >> newline'- blockCmnt = L.skipBlockComment "/*" "*/" >> newline'--newline' :: Parser ()-newline' = void sc >> void (many newline) >> void sc--backticks :: Parser a -> Parser a-backticks = between (symbol "`") (symbol "`")--braces :: Parser a -> Parser a-braces = between (symbol "{") (symbol "}")--lparen, rparen, lbrac, rbrac :: Parser ()-lbrac = void (symbol "{")-rbrac = void (symbol "}")-lparen = void (symbol "(")-rparen = void (symbol ")")--parens :: Parser a -> Parser a-parens = between (symbol "(") (symbol ")")--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--comma :: Parser String-comma = symbol ","--symbol :: String -> Parser String-symbol = L.symbol sc--integer :: Parser Integer-integer = lexeme L.integer--float :: Parser Float-float = realToFrac <$> lexeme L.float -- TODO: parsing without sign?--identifier :: Parser String-identifier = (lexeme . try) (p >>= check)- where- p = (:) <$> letterChar <*> many alphaNumChar- check x = if x `elem` rws- then fail $ "keyword " ++ show x ++ " cannot be an identifier"- else return x---- Reserved words-rword :: String -> Parser ()-rword w = string w *> notFollowedBy alphaNumChar *> sc--rws, attribs, attribVs, shapes, types :: [String] -- list of reserved words-rws = ["avoid", "global", "as"] ++ types ++ shapes--- ++ types ++ attribs ++ shapes ++ colors--types = ["Set", "Map", "Point"]-attribs = ["shape", "color", "label", "scale", "position"]-attribVs = shapes ++ colors-shapes = ["Auto", "None", "Circle", "Box", "SolidArrow", "SolidDot", "HollowDot", "Cross"]-colors = ["Random", "Black", "Red", "Blue", "Yellow"]------ getType :: String -> SubType--- getType str = case str of--- "Set" -> Set--- "Map" -> Map--- "Point" -> Pt--- "Subset" -> Subset--------- getAttribute :: String -> Attribute--- getAttribute str = case str of--- "shape" -> Shape--- "color" -> Color--- "bordor" -> LineType--------- getAttributeV :: String -> AttributeV--- getAttributeV str = case str of--- "None" -> ShapeV NoShape--- "Circle" -> ShapeV $ SS SetCircle--- "Box" -> ShapeV $ SS Box--- "SolidArrow" -> ShapeV $ SM SolidArrow--- "SolidDot" -> ShapeV $ SP SolidDot--- "HollowDot" -> ShapeV $ SP HollowDot--- "Cross" -> ShapeV $ SP Cross--- "Red" -> ColorV Red--- "Yellow" -> ColorV Yellow--- "Blue" -> ColorV Blue--- "Black" -> ColorV Black--- "Random" -> ColorV Random------ attribute :: Parser Attribute--- attribute = (lexeme . try) (p >>= check)--- where--- p = many letterChar--- check x = if x `elem` attribs--- then return (getAttribute x)--- else fail $ "keyword " ++ show x ++ " cannot be an attribute"------ attributeValue :: Parser AttributeV--- attributeValue = (lexeme . try) (p >>= check)--- where--- p = many letterChar--- check x = if x `elem` attribVs--- then return (getAttributeV x)--- else fail $ "keyword " ++ show x ++ " cannot be an attribute value"------ typ :: Parser SubType--- typ = (lexeme . try) (p >>= check)--- where--- p = some letterChar--- check x = if x `elem` types--- then return (getType x)--- else fail $ "Type " ++ show x ++ " is not a valid type"------ -- access :: Parser Expr--- -- access = do--- -- i <- identifier--- -- void (symbol ".")--- -- a <- attributeName--- -- return (Access i a)---------------- -- TODO--- styPrettyPrint :: Block -> String--- styPrettyPrint b = "HAHAHAHA"--parseFromFile p file = runParser p file <$> readFile file--main :: IO ()-main = do- args <- getArgs- let styFile = head args- styIn <- readFile styFile- -- putStrLn styIn- -- parseTest styleParser styIn- case runParser styleParser styFile styIn of- Left err -> putStr (parseErrorPretty err)- Right xs -> mapM_ print xs- return ()
+ src/Style.hs view
@@ -0,0 +1,1536 @@+-- | The "Style" module contains the compiler for the Style language,+-- and functions to traverse the Style AST.++{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, UnicodeSyntax, NoMonomorphismRestriction, FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+-- Mostly for autodiff++module Style where++import Utils+import Shapes hiding (get)+import Functions+import Control.Monad (void, foldM)+import Control.Monad.State.Lazy (evalStateT, get)+import Control.Applicative ((<**>))+import Data.Function (on)+import Data.Either (partitionEithers)+import Data.Either.Extra (fromLeft)+import Data.Maybe (fromMaybe, catMaybes, isNothing, maybeToList)+import Data.List (nubBy, nub, intercalate, partition, sort)+import Data.Tuple (swap)+import Text.Megaparsec+import Text.Megaparsec.Char+import Control.Applicative.Permutations+import Control.Monad.Combinators.Expr+import Text.Show.Pretty (ppShow)+import System.Environment+import System.Random+import Debug.Trace+import qualified Substance as C+import qualified Data.Map.Strict as M+import qualified Text.Megaparsec.Char.Lexer as L+import SubstanceJSON as J+import Data.Dynamic+import Data.Typeable+import Env++--------------------------------------------------------------------------------+-- Plugin Parser++-- | A Style program can have an instantiator, which would expand its corresponding Substance program via an external program. The instantiator is specified with a string+-- NOTE: for now, we would allow multiple instantiation statements, but only use the __first__ instantiator in the Style program+type Plugin = String+type Plugins = [Plugin]++-- | 'parsePlugins' parses a Style program and return a list of instantiators declared at the __top__ of the program.+-- NOTE: this parse do run the Style parser to check for ill-formed instantiation statements. Therefore, a 'VarEnv' is required to run this parser without any errors+parsePlugins :: String -> String -> VarEnv -> Either CompilerError Plugins+parsePlugins styFile styIn env =+ case runParser (pluginParser env) styFile styIn of+ Left err -> Left $ PluginParse $ (errorBundlePretty err)+ Right instantiation -> Right instantiation++pluginParser :: VarEnv -> BaseParser Plugins+pluginParser env = evalStateT pluginParser' $ Just env++pluginParser' :: Parser Plugins+pluginParser' = do+ scn+ res <- plugins+ _ <- styProg+ return res+ where restOfFile = manyTill anySingle eof >> return []++plugins :: Parser Plugins+plugins = plugin `endBy` newline' -- zero or multiple instantiators++plugin :: Parser Plugin+plugin = symbol "plugin" >> stringLiteral++stringLiteral :: Parser String+stringLiteral = symbol "\"" >> manyTill L.charLiteral (try (symbol "\""))++--------------------------------------------------------------------------------+-- Style AST++-------------------- Style Program grammar++-- | A variable in Style+newtype StyVar = StyVar' String+ deriving (Show, Eq, Ord, Typeable)++-- | A header of a block is either a selector or a namespace declaration+data Header = Select Selector | Namespace StyVar+ deriving (Show, Eq, Typeable)++-- | A Style block contains a list of statements+type Block = [Stmt]++-- | A Style program is a collection of (header, block) pairs+type StyProg = [(Header, Block)]++-------------------- Style selector grammar+-- TODO: write a NOTE about the namespace situation between Substance and Style.++data STypeVar = STypeVar' {+ typeVarNameS :: String,+ typeVarPosS :: SourcePos+} deriving (Eq, Typeable)+instance Show STypeVar where+ show = show . typeVarNameS++-- | A type in Style can be TODO (Alias because of T in `Env`)+data StyT = STTypeVar STypeVar+ | STCtor STypeCtor+ deriving (Show, Eq, Typeable)++data STypeCtor = STypeCtor {+ nameConsS :: String,+ argConsS :: [SArg],+ posConsS :: SourcePos+} deriving (Eq, Typeable)+instance Show STypeCtor where+ show t = show (nameConsS t) ++ show (argConsS t)++data SArg+ = SAVar BindingForm+ | SAT StyT+ deriving (Show, Eq, Typeable)++data SelExpr+ = SEBind BindingForm+ | SEAppFunc String [SelExpr]+ | SEAppValCons String [SelExpr]+ deriving (Show, Eq, Typeable)++data PredArg+ = PE SelExpr -- TODO: this should only be allowed to be a Var in Sub (and maybe in Sty?)+ | PP Predicate+ deriving (Show, Eq, Typeable)++data Predicate = Predicate {+ predicateName :: String,+ predicateArgs :: [PredArg],+ predicatePos :: SourcePos+} deriving (Eq, Typeable)++instance Show Predicate where+ show t = show (predicateName t) ++ show (predicateArgs t)++-- | A binding form can either be a newly declared Style id or an existing+-- Substance id, which is denoted by the special @``@ characters+data BindingForm = BSubVar Var | BStyVar StyVar+ deriving (Show, Eq, Ord, Typeable)++data DeclPattern = PatternDecl' StyT BindingForm+ deriving (Show, Eq, Typeable)++data RelationPattern = RelBind BindingForm SelExpr | RelPred Predicate+ deriving (Show, Eq, Typeable)++-- | A selector is TODO+data Selector = Selector {+ selHead :: [DeclPattern],+ selWith :: [DeclPattern],+ selWhere :: [RelationPattern],+ selNamespace :: Maybe String+} deriving (Show, Eq, Typeable)++-------------------- Style block grammar++type Field = String++-- | A path consist of a Substance or Style id, a shape name, and (optionally)+-- a property name+data Path+ = FieldPath BindingForm Field -- example: x.val+ | PropertyPath BindingForm Field Property -- example: x.shape.center+ -- NOTE: Style writer must use backticks in the block to indicate Substance variables+ deriving (Show, Eq, Typeable, Ord)++-- | A statement in the Style language+data Stmt+ = Assign Path Expr+ | Override Path Expr+ | Delete Path+ deriving (Show, Eq, Typeable)++-- | A field declaration in a Style constructor binds an expression to a+-- string+data PropertyDecl = PropertyDecl String Expr+ deriving (Show, Eq, Typeable)++data AnnoFloat = Fix Float | Vary+ deriving (Show, Eq, Typeable)++-- | An expression in the Style language+data Expr+ = IntLit Integer+ | AFloat AnnoFloat+ | StringLit String+ | BoolLit Bool+ | EPath Path+ | CompApp String [Expr]+ | ObjFn String [Expr]+ | ConstrFn String [Expr]+ | AvoidFn String [Expr] -- TODO: to be implemented+ | BinOp BinaryOp Expr Expr+ | UOp UnaryOp Expr+ | List [Expr]+ | Tuple Expr Expr+ | ListAccess Path Integer+ | Ctor String [PropertyDecl] -- Shouldn't be using this, since we have PropertyDict+ | Layering Path Path -- ^ first GPI is *below* the second GPI+ | PluginAccess String Expr Expr -- ^ Plugin name, Substance name, Key+ | ThenOp Expr Expr -- COMBAK: double check how transforms are modeled, probably just a list of CompApp+ deriving (Show, Eq, Typeable)++data LayerOp = Less | Seq+ deriving (Show, Eq, Typeable)++data UnaryOp = UPlus | UMinus+ deriving (Show, Eq, Typeable)++data BinaryOp = BPlus | BMinus | Multiply | Divide | Exp+ deriving (Show, Eq, Typeable)++--------------------------------------------------------------------------------+-- Style Parser++-- | 'parseStyle' runs the actual parser function: 'styleParser', taking in a program String and parse it into an AST.+parseStyle :: String -> String -> VarEnv -> Either CompilerError StyProg+parseStyle styFile styIn env =+ case runParser (styleParser env) styFile styIn of+ Left err -> Left $ StyleParse $ (errorBundlePretty err)+ Right res -> Right res++-- | 'styleParser' is the top-level function that parses a Style proram+styleParser :: VarEnv -> BaseParser StyProg+styleParser env = evalStateT styleParser' $ Just env+styleParser' = between scn eof styProg++-- | `styProg` parses a Style program, consisting of a collection of one or+-- more blocks+styProg :: Parser StyProg+styProg =+ plugins >> -- ignore plugin statements+ some headerBlock+ where headerBlock = (,) <$> header <*> braces block <* scn++header :: Parser Header+header = tryChoice [Select <$> selector, Namespace <$> styVar]++-------------------- Selector parsers+-- COMBAK: short-hand for decls with the same type+-- COMBAK: change commas to semicolons++-- TODO: clear up the `scn` calls for all parsers and establish the convention of calling scn AFTER each parser+selector :: Parser Selector+selector = do+ hd <- fmap concat $ declPattern `sepBy1` semi' <* scn+ (wi, wh) <- withAndWhere+ ns <- optional $ namespace <* scn+ return Selector { selHead = hd, selWith = wi, selWhere = wh,+ selNamespace = ns}+ where wth = fmap concat $ rword "with" *> declPattern `sepEndBy1` semi' <* scn+ whr = rword "where" *> relationPattern `sepEndBy1` semi' <* scn+ namespace = rword "as" >> identifier+ withAndWhere = runPermutation $ (,) <$> toPermutationWithDefault [] wth <*> toPermutationWithDefault [] whr++styVar :: Parser StyVar+styVar = StyVar' <$> identifier++declPattern :: Parser [DeclPattern]+declPattern = do+ t <- styType+ ns <- bindingForm `sepBy1` comma+ return $ map (PatternDecl' t) ns++styType :: Parser StyT+styType = STTypeVar <$> typeVar <|> STCtor <$> typeConstructor++typeVar :: Parser STypeVar+typeVar = do+ aps -- COMBAK: get rid of this later once it's consistent with DSLL/Substance+ t <- identifier+ pos <- getSourcePos+ return STypeVar' { typeVarNameS = t, typeVarPosS = pos}++typeConstructor :: Parser STypeCtor+typeConstructor = do+ n <- identifier+ args <- option [] $ parens (styArgument `sepBy1` comma)+ pos <- getSourcePos+ return STypeCtor { nameConsS = n, argConsS = args, posConsS = pos }++-- COMBAK: styType will probably not work because of recursion. Test this explicitly+styArgument :: Parser SArg+styArgument = SAVar <$> bindingForm <|> SAT <$> styType++relationPattern :: Parser RelationPattern+relationPattern = try pre <|> bind+ where bind = RelBind <$> bindingForm <*> (def >> selectorExpr)+ pre = RelPred <$> predicate++predicate :: Parser Predicate+predicate = do+ n <- identifier+ args <- parens $ predicateArgument `sepBy1` comma+ pos <- getSourcePos+ return Predicate { predicateName = n, predicateArgs = args,+ predicatePos = pos }++predicateArgument :: Parser PredArg+predicateArgument = PE <$> selectorExpr <|> PP <$> predicate++selectorExpr :: Parser SelExpr+selectorExpr =+ try selectorValConsOrFunc <|>+ SEBind <$> bindingForm++bindingForm :: Parser BindingForm+bindingForm = BSubVar <$> backticks varParser <|> BStyVar <$> styVar++-- NOTE: this is a duplication of "valConsOrFunc" in Substance parser, with selector specific types+selectorValConsOrFunc :: Parser SelExpr+selectorValConsOrFunc = do+ n <- identifier+ e <- get+ let env = fromMaybe (error "Style parser: variable environment is not intiialized.") e+ args <- parens (selectorExpr `sepBy1` comma)+ case (M.lookup n $ valConstructors env, M.lookup n $ operators env) of+ -- the id is a value constructor+ (Just _, Nothing) -> return $ SEAppValCons n args+ -- the id is an operator+ (Nothing, Just _) -> return $ SEAppFunc n args+ (Nothing, Nothing) -> styleErr $ "undefined identifier " ++ n+ _ -> styleErr $ n ++ " cannot be both a value constructor and an operator"+ where styleErr s = customFailure (StyleError s)++-------------------- Block parsers++block :: Parser [Stmt]+block = stmt `sepEndBy` newline'++stmt :: Parser Stmt+stmt = tryChoice [assign, override, delete]++assign, override, delete :: Parser Stmt+assign = Assign <$> path <*> (eq >> expr)+override = Override <$> (rword "override" >> path) <*> (eq >> expr)+delete = Delete <$> (rword "delete" >> path)++expr :: Parser Expr+expr = tryChoice [+ constructor,+ layeringExpr,+ arithmeticExpr,+ objFn,+ constrFn,+ transformExpr, -- COMBAK: ordering+ compFn,+ list,+ tuple,+ stringLit,+ boolLit+ ]++pluginAccess :: Parser Expr+pluginAccess = do+ plugin <- identifier+ name <- bExpr+ key <- bExpr+ return $ PluginAccess plugin name key+ where bExpr = brackets expr++arithmeticExpr :: Parser Expr+arithmeticExpr = makeExprParser aTerm aOperators++aTerm :: Parser Expr+aTerm = tryChoice+ [+ compFn,+ pluginAccess,+ parens arithmeticExpr,+ AFloat <$> annotatedFloat,+ EPath <$> path,+ IntLit <$> integer+ ]++aOperators :: [[Control.Monad.Combinators.Expr.Operator Parser Expr]]+aOperators =+ [ -- Highest precedence+ [+ Prefix (UOp UMinus <$ symbol "-"),+ Prefix (UOp UPlus <$ symbol "+")+ ],+ [ InfixL (BinOp Exp <$ symbol "^") ],+ [+ InfixL (BinOp Multiply <$ symbol "*"),+ InfixL (BinOp Divide <$ symbol "/")+ ],+ [+ InfixL (BinOp BPlus <$ symbol "+"),+ InfixL (BinOp BMinus <$ symbol "-")+ ]+ -- Lowest precedence+ ]++layeringExpr :: Parser Expr+layeringExpr = try layeringAbove <|> layeringBelow+ where+ layeringBelow = Layering <$> path <* rword "below" <*> path+ layeringAbove = do+ path1 <- path+ rword "above"+ path2 <- path+ return $ Layering path2 path1++transformExpr :: Parser Expr+transformExpr = makeExprParser tTerm tOperators++tTerm :: Parser Expr+tTerm = compFn++tOperators :: [[Control.Monad.Combinators.Expr.Operator Parser Expr]]+tOperators =+ [ -- Highest precedence+ [ InfixL (ThenOp <$ symbol "then") ]+ -- Lowest precedence+ ]++path :: Parser Path+path = try (PropertyPath <$> bindingForm <*> dotId <*> dotId) <|>+ FieldPath <$> bindingForm <*> dotId+ where dotId = dot >> identifier++compFn, objFn, constrFn :: Parser Expr+compFn = CompApp <$> identifier <*> exprsInParens+objFn = ObjFn <$> (rword "encourage" >> identifier) <*> exprsInParens+constrFn = ConstrFn <$> (rword "ensure" >> identifier) <*> exprsInParens+exprsInParens = parens $ expr `sepBy` comma++list, tuple :: Parser Expr+list = List <$> brackets (expr `sepBy1` comma)+tuple = parens (Tuple <$> expr <*> (comma >> expr))++constructor :: Parser Expr+constructor = do+ typ <- identifier+ fields <- braces (propertyDecl `sepEndBy` newline')+ return $ Ctor typ fields++propertyDecl :: Parser PropertyDecl+propertyDecl = PropertyDecl <$> identifier <*> (colon >> expr)++boolLit :: Parser Expr+boolLit = (rword "True" >> return (BoolLit True))+ <|> (rword "False" >> return (BoolLit False))++stringLit :: Parser Expr+-- NOTE: overlapping parsers 'charLiteral' and 'char '"'', so we use 'try'+stringLit = StringLit <$> (symbol "\"" >> manyTill L.charLiteral (try (symbol "\"")))++annotatedFloat :: Parser AnnoFloat+annotatedFloat = (question *> pure Vary) <|> Fix <$> float++------------------------------------------------------------------------+-------- STYLE COMPILER++----- Debug info++debugM1, debugM2, debugM3 :: Bool+debugM1 = False+debugM2 = False+debugM3 = False++mkTr :: Bool -> String -> a -> a+mkTr flag str res = if flag then trace str res else res++-- matching+trM1 = mkTr debugM1+-- statics+trM2 = mkTr debugM2+-- translation+trM3 = mkTr debugM3++-- Style static semantics for selectors++------------ Type defs++-- g ::= B => |T+-- Assumes nullary type constructors (i.e. Style type = Substance type)+data SelEnv = SelEnv { sTypeVarMap :: M.Map BindingForm StyT, -- B : |T+ sErrors :: [String] }+ deriving (Show, Eq, Typeable)++type Error = String++------------ Helper functions on envs++initSelEnv :: SelEnv+initSelEnv = SelEnv { sTypeVarMap = M.empty, sErrors = [] }++-- g, x : |T+addMapping :: BindingForm -> StyT -> SelEnv -> SelEnv+addMapping k v m = m { sTypeVarMap = M.insert k v (sTypeVarMap m) }++addErr :: Error -> SelEnv -> SelEnv+addErr err selEnv = selEnv { sErrors = err : sErrors selEnv }++addErrs :: [Error] -> SelEnv -> SelEnv+addErrs errs selEnv = selEnv { sErrors = sErrors selEnv ++ errs }++-- TODO: don't merge the varmaps! just put g as the varMap (otherwise there will be extraneous bindings for the relational statements)+-- Judgment 1. G || g |-> ...+mergeEnv :: VarEnv -> SelEnv -> VarEnv+mergeEnv varEnv selEnv = foldl mergeMapping varEnv (M.assocs $ sTypeVarMap selEnv)+ where mergeMapping :: VarEnv -> (BindingForm, StyT) -> VarEnv+ -- G || (x : |T) |-> G+ mergeMapping varEnv (BSubVar var, styType) = varEnv+ -- G || (y : |T) |-> G[y : T] (shadowing any existing Sub vars)+ mergeMapping varEnv (BStyVar (StyVar' var), styType) =+ varEnv { varMap = M.insert (VarConst var) (toSubType styType) (varMap varEnv) }++----------- Converting Style values to Env/Substance values for two reasons:+-- 1. so they can be put into Gamma, 2. so the normal Substance judgments can be reused (e.g. T : type)++-- | All Style variables "y" are converted to Substance vars "`x`"+toSubVar :: BindingForm -> Var+toSubVar (BSubVar subv) = subv+toSubVar (BStyVar (StyVar' styv)) = VarConst styv++toSubTArg :: SArg -> Arg+toSubTArg (SAVar bVar) = AVar $ toSubVar bVar+toSubTArg (SAT styT) = AT $ toSubType styT++-- | Convert a Style type to a Substance type. (This has nothing to do with subtyping)+toSubType :: StyT -> T+toSubType (STTypeVar stvar) = TTypeVar $ TypeVar { typeVarName = typeVarNameS stvar,+ typeVarPos = typeVarPosS stvar }+toSubType (STCtor stcons) = TConstr $ TypeCtorApp { nameCons = nameConsS stcons,+ argCons = map toSubTArg $ argConsS stcons,+ constructorInvokerPos = posConsS stcons }++toSubExpr :: SelExpr -> C.Expr+toSubExpr (SEBind bvar) = C.VarE $ toSubVar bvar+toSubExpr (SEAppFunc f exprs) = C.ApplyFunc $ C.Func { C.nameFunc = f, C.argFunc = map toSubExpr exprs }+toSubExpr (SEAppValCons v exprs) = C.ApplyValCons $ C.Func { C.nameFunc = v, C.argFunc = map toSubExpr exprs }++toSubPredArg :: PredArg -> C.PredArg+toSubPredArg (PE selExpr) = C.PE $ toSubExpr selExpr+toSubPredArg (PP pred) = C.PP $ toSubPred pred++toSubPred :: Predicate -> C.Predicate+toSubPred stypred = C.Predicate { C.predicateName = C.PredicateConst $ predicateName stypred,+ C.predicateArgs = map toSubPredArg $ predicateArgs stypred,+ C.predicatePos = predicatePos stypred }++----------- Selector static semantics++-- For `B := E`, make sure `B : T` and `E : T`+compareTypes :: RelationPattern -> BindingForm -> SelExpr -> Maybe T -> Maybe T -> Maybe Error+compareTypes stmt var expr vtype etype =+ case (vtype, etype) of+ (Nothing, Nothing) ->+ Just $ "In Style statement '" ++ show stmt ++ "', the var and expr" ++ " are both of invalid type."+ (Just vtype', Nothing) ->+ Just $ "In Style statement '" ++ show stmt ++ "', the expr '" ++ show expr +++ " should have type '" ++ show vtype' ++ "' but does not have a type."+ (Nothing, Just etype') ->+ Just $ "In Style statement '" ++ show stmt ++ "', the var '" ++ show var +++ " should have type '" ++ show etype' ++ "' but does not have a type."+ (Just vtype', Just etype') ->+ if typesEq (trM2 ("VTYPE: " ++ show vtype') vtype') (trM2 ("ETYPE: " ++ show etype') etype') then Nothing+ else Just $ "In Style statement '" ++ show stmt ++ "', the var and expr" +++ " should have the same type, but have types '" ++ show vtype' +++ "' and '" ++ show etype' ++ "'."++-- Judgment 5. G |- [|S_r] ok+checkRelPatterns :: VarEnv -> [RelationPattern] -> [Error]+checkRelPatterns varEnv rels = concatMap (checkRelPattern varEnv) rels+ -- Judgment 4. G |- |S_r ok+ where checkRelPattern :: VarEnv -> RelationPattern -> [Error]+ checkRelPattern varEnv rel =+ case rel of+ -- rule Bind-Context+ RelBind bVar sExpr ->+ -- TODO: use checkSubStmt here (and in paper)?+ -- TODO: make sure the ill-typed bind selectors fail here (after Sub statics is fixed)+ -- G |- B : T1+ let (error1, vtype) = C.checkVarE varEnv+ (trM2 ("B: " ++ show (toSubVar bVar)) $ toSubVar bVar) in+ -- G |- E : T2+ let (error2, etype) = C.checkExpression varEnv+ (trM2 ("E: " ++ show (toSubExpr sExpr)) $ toSubExpr sExpr) in+ -- T1 = T2+ let err3 = compareTypes rel bVar sExpr vtype etype in+ case trM2 ("ERR3: " ++ show err3) err3 of+ Nothing -> [error1, error2]+ Just e3 -> [error1, error2, e3]+ -- rule Pred-Context+ RelPred pred ->+ -- G |- Q : Prop+ let varEnv' = C.checkPredicate varEnv $ toSubPred pred in+ [errors varEnv']++-- Judgment 6. G; g |- [|S_o] ~> g'+checkDeclPatterns :: VarEnv -> SelEnv -> [DeclPattern] -> SelEnv+checkDeclPatterns varEnv selEnv decls = foldl (checkDeclPattern varEnv) selEnv decls+ -- Judgment 3. G; g |- |S_o ok ~> g'+ where checkDeclPattern :: VarEnv -> SelEnv -> DeclPattern -> SelEnv+ checkDeclPattern varEnv selEnv stmt@(PatternDecl' styType bVar) =+ -- G |- |T : type+ let errT = errors $ checkT varEnv (toSubType styType) in+ let selEnv' = addErr errT selEnv in+ case bVar of+ -- rule Decl-Sty-Context+ bsv@(BStyVar (StyVar' styVar)) ->+ -- NOTE: this does not aggregate *all* possible error May just return first error.+ -- y \not\in dom(g)+ if M.member bsv (sTypeVarMap selEnv')+ then let err = "Style pattern statement " ++ show stmt +++ " declares Style variable '" ++ styVar ++ "' twice"+ in addErr err selEnv'+ else if M.member (BSubVar (VarConst styVar)) (sTypeVarMap selEnv')+ then let err = "Style pattern statement " ++ show stmt +++ " declares Style variable '" ++ styVar ++ "'" +++ " in the same selector as a Substance variable of the same name"+ in addErr err selEnv'+ else addMapping bsv styType selEnv'+ -- rule Decl-Sub-Context+ bsv@(BSubVar subVar@(VarConst sVar)) ->+ -- x \not\in dom(g)+ if M.member bsv (sTypeVarMap selEnv')+ then let err = "Style pattern statement " ++ show stmt +++ " declares Substance variable '" ++ sVar ++ "' twice"+ in addErr err selEnv'+ else if M.member (BStyVar (StyVar' sVar)) (sTypeVarMap selEnv')+ then let err = "Style pattern statement " ++ show stmt +++ " declares Substance variable '" ++ sVar ++ "'" +++ " in the same selector as a Style variable of the same name"+ in addErr err selEnv'+ else+ -- G(x) = T+ let subType = M.lookup subVar $ varMap varEnv in+ case subType of+ Nothing -> let err = "Substance variable '" ++ show subVar +++ "' does not exist in environment. \n" {- ++ show varEnv -} in+ addErr err selEnv'+ Just subType' ->+ -- check "T <: |T", assuming type constructors are nullary+ let declType = toSubType styType in+ if subType' == declType+ || isSubtype subType' declType varEnv+ then addMapping bsv styType selEnv'+ else let err = "Mismatched types between Substance and Style var\n" +++ "Sub var '" ++ show subVar ++ "' has type '" ++ show subType' +++ "in Substance but has type '" ++ show declType ++ "' in Style."+ in addErr err selEnv'++-- Judgment 7. G |- Sel ok ~> g+checkSel :: VarEnv -> Selector -> SelEnv+checkSel varEnv sel =+ -- Check head statements+ let selEnv_afterHead = checkDeclPatterns varEnv initSelEnv (selHead sel) in+ -- Check `with` statements+ let selEnv_decls = checkDeclPatterns varEnv selEnv_afterHead (selWith sel) in+ -- Check relational statements+ let rel_errs = checkRelPatterns (mergeEnv varEnv selEnv_decls) (selWhere sel) in+ selEnv_decls { sErrors = filter (/= "") $ reverse (sErrors selEnv_decls) ++ rel_errs }++checkNamespace :: String -> VarEnv -> SelEnv+checkNamespace name varEnv =+ -- A Substance variable cannot have the same name as a namespace+ let error = if M.member (VarConst name) (varMap varEnv)+ then ["Substance variable '" ++ name ++ "' has the same name as a namespace in the Style program"]+ else []+ in addErrs error initSelEnv++-- Returns a sel env for each selector in the Style program, in the same order+-- TODO: add these judgments to the paper+checkSels :: VarEnv -> StyProg -> [SelEnv]+checkSels varEnv prog =+ let selEnvs = map (checkPair varEnv) prog in+ let errors = concatMap sErrors selEnvs in+ if null errors+ then selEnvs+ else error $ intercalate "\n" errors+ where checkPair :: VarEnv -> (Header, Block) -> SelEnv+ checkPair varEnv (Select sel, _) = checkSel varEnv sel+ checkPair varEnv (Namespace (StyVar' name), _) = checkNamespace name varEnv+ -- TODO: for now, namespace has no local context++-- TODO: namespaces are implicitly converted to Substance variables somewhere (not sure where)+-- TODO: write test cases (including failing ones) after Substance errors are no longer @ runtime+-- TODO: get line/col numbers for errors++----------- Selector dynamic semantics (matching)++----- Type declarations++-- A substitution θ has form [y → x], binding Sty vars to Sub vars (currently not expressions).+type Subst = M.Map StyVar Var++type LocalVarId = (Int, Int)+-- Index of the block, paired with the index of the current substitution+-- Should be unique across blocks and substitutions++localKeyword :: String+localKeyword = "LOCAL"++mkLocalVarName :: LocalVarId -> String+mkLocalVarName (blockNum, substNum) = localKeyword ++ "_b" ++ show blockNum ++ "_s" ++ show substNum++----- Substitution helper functions++-- (+) operator combines two substitutions: subst -> subst -> subst+combine :: Ord k => M.Map k a -> M.Map k a -> M.Map k a+combine s1 s2 = M.union s1 s2+-- TODO check for duplicate keys (and vals)++-- (x) operator combines two lists of substitutions: [subst] -> [subst] -> [subst]+-- the way merge is used, I think each subst in the second argument only contains one mapping+merge :: Ord k => [M.Map k a] -> [M.Map k a] -> [M.Map k a]+merge s1 [] = s1+merge [] s2 = s2+merge s1 s2 = [ combine s1i s2j | s1i <- s1, s2j <- s2 ] -- TODO check wrt maps++allUnique :: Eq a => [a] -> Bool+allUnique l = nub l == l++isStyVar :: BindingForm -> Bool+isStyVar (BStyVar _) = True+isStyVar (BSubVar _) = False++-- Judgment 20. A substitution for a selector is only correct if it gives exactly one+-- mapping for each Style variable in the selector.+fullSubst :: SelEnv -> Subst -> Bool+fullSubst selEnv subst =+ let selStyVars = map styVarToString $ filter isStyVar $ M.keys $ sTypeVarMap selEnv+ substStyVars = map styVarToString' $ M.keys subst+ res = sort selStyVars == sort substStyVars in+ -- Equal up to permutation (M.keys ensures that there are no dups)+ trM1 ("fullSubst: \nselEnv: " ++ ppShow selEnv ++ "\nsubst: " ++ ppShow subst ++ "\nres: " ++ ppShow res ++ "\n") res+ where styVarToString (BStyVar (StyVar' v)) = v+ styVarToString' (StyVar' v) = v++-- Check that there are no duplicate keys or vals in the substitution+uniqueKeysAndVals :: Subst -> Bool+uniqueKeysAndVals subst =+ let (keys, vals) = unzip $ M.toList subst in+ allUnique keys && allUnique vals+ -- if not (allUnique keys && allUnique vals)+ -- then error ("substitution contains some duplicated keys or vals:\n" ++ show keys ++ "\n" ++ show vals)+ -- else True++----- Apply a substitution to various parts of Style (relational statements, exprs, blocks)+-- Recursively walk the tree, looking up and replacing each Style variable encountered with a Substance variable+-- If a Sty var doesn't have a substitution (i.e. substitution map is bad), keep the Sty var and move on++-- TODO: return "maybe" if a substitution fails?++substituteBform :: Maybe LocalVarId -> Subst -> BindingForm -> BindingForm+-- Variable in backticks in block or selector (e.g. `X`)+substituteBform _ subst sv@(BSubVar _) = sv++-- If the Style variable is "LOCAL", then resolve it to a unique id for the block and selector+-- Otherwise, look up the substitution for the Style variable and return a Substance variable+substituteBform lv subst sv@(BStyVar sv'@(StyVar' vn)) =+ if vn == localKeyword+ then case lv of+ -- lv = Nothing: substituting into selector, so local vars don't matter+ -- lv = Just (i, j): substituting into block, so local vars matter+ Nothing -> error "LOCAL keyword found without a subst/block id. It should not be used in a selector."+ Just localVarId -> BSubVar $ VarConst $ mkLocalVarName localVarId+ else case M.lookup sv' subst of+ Just subVar -> BSubVar subVar -- Returns result of mapping if it exists (y -> x)+ Nothing -> sv -- error $ "No subst found for Sty var '" ++ vn ++ "'"+ -- TODO: no substitutions for namespaces++substituteExpr :: Subst -> SelExpr -> SelExpr+-- theta(B) = ...+substituteExpr subst (SEBind bvar) = SEBind $ substituteBform Nothing subst bvar+-- theta(f[E]) = f([theta(E)]+substituteExpr subst (SEAppFunc fname exprs) = SEAppFunc fname $ map (substituteExpr subst) exprs+-- theta(v([E])) = v([theta(E)])+substituteExpr subst (SEAppValCons vname exprs) = SEAppValCons vname $ map (substituteExpr subst) exprs++substitutePredArg :: Subst -> PredArg -> PredArg+substitutePredArg subst (PE expr) = PE $ substituteExpr subst expr+substitutePredArg subst (PP pred) = PP $ substitutePred subst pred++substitutePred :: Subst -> Predicate -> Predicate+substitutePred subst pred = pred { predicateArgs = map (substitutePredArg subst) $ predicateArgs pred }++-- theta(|S_r) = ...+substituteRel :: Subst -> RelationPattern -> RelationPattern+-- theta(B := E) |-> theta(B) := theta(E)+substituteRel subst (RelBind bvar sExpr) = RelBind (substituteBform Nothing subst bvar)+ (substituteExpr subst sExpr)+-- theta(Q([a]) = Q([theta(a)])+substituteRel subst (RelPred pred) = RelPred $ substitutePred subst pred++-- Applies a substitution to a list of relational statement theta([|S_r])+-- TODO: assumes a full substitution+substituteRels :: Subst -> [RelationPattern] -> [RelationPattern]+substituteRels subst rels = map (substituteRel subst) rels++----- Substs for the translation semantics (more tree-walking on blocks, just changing binding forms)++substitutePath :: LocalVarId -> Subst -> Path -> Path+substitutePath lv subst path =+ case path of+ FieldPath bVar field -> FieldPath (substituteBform (Just lv) subst bVar) field+ PropertyPath bVar field prop -> PropertyPath (substituteBform (Just lv) subst bVar) field prop++substituteField :: LocalVarId -> Subst -> PropertyDecl -> PropertyDecl+substituteField lv subst (PropertyDecl field expr) = PropertyDecl field $ substituteBlockExpr lv subst expr+++-- DEPRECATED+-- substituteLayering :: LocalVarId -> Subst -> LExpr -> LExpr+-- substituteLayering lv subst (LId bVar) = LId $ substituteBform (Just lv) subst bVar+-- substituteLayering lv subst (LPath path) = LPath $ substitutePath lv subst path+-- substituteLayering lv subst (LayeringOp op lex1 lex2) =+-- LayeringOp op (substituteLayering lv subst lex1) (substituteLayering lv subst lex1)++substituteBlockExpr :: LocalVarId -> Subst -> Expr -> Expr+substituteBlockExpr lv subst expr =+ case expr of+ EPath path -> EPath $ substitutePath lv subst path+ CompApp f es -> CompApp f $ map (substituteBlockExpr lv subst) es+ ObjFn f es -> ObjFn f $ map (substituteBlockExpr lv subst) es+ ConstrFn f es -> ConstrFn f $ map (substituteBlockExpr lv subst) es+ AvoidFn f es -> AvoidFn f $ map (substituteBlockExpr lv subst) es+ BinOp op e1 e2 -> BinOp op (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)+ UOp op e -> UOp op (substituteBlockExpr lv subst e)+ List es -> List $ map (substituteBlockExpr lv subst) es+ ListAccess path i -> ListAccess (substitutePath lv subst path) i+ Ctor gpi fields -> Ctor gpi $ map (substituteField lv subst) fields+ Layering path1 path2 -> Layering (substitutePath lv subst path1) (substitutePath lv subst path2)+ -- No substitution for literals+ IntLit _ -> expr+ AFloat _ -> expr+ StringLit _ -> expr+ BoolLit _ -> expr+ -- TODO: check if this is right+ PluginAccess pluginName e1 e2 -> PluginAccess pluginName (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)+ Tuple e1 e2 -> Tuple (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)+ ThenOp e1 e2 -> ThenOp (substituteBlockExpr lv subst e1) (substituteBlockExpr lv subst e2)++substituteLine :: LocalVarId -> Subst -> Stmt -> Stmt+substituteLine lv subst line =+ case line of+ Assign path expr -> Assign (substitutePath lv subst path) (substituteBlockExpr lv subst expr)+ Override path expr -> Override (substitutePath lv subst path) (substituteBlockExpr lv subst expr)+ Delete path -> Delete $ substitutePath lv subst path++-- Assumes a full substitution+substituteBlock :: (Subst, Int) -> (Block, Int) -> Block+substituteBlock (subst, substNum) (block, blockNum) = map (substituteLine (blockNum, substNum) subst) block++----- Filter with relational statements++-- Intentionally pulling out variable equality judgment (. |- x1 = x2) as string equality+varsEq :: Var -> Var -> Bool+varsEq = (==)++exprToVar :: C.Expr -> Var+exprToVar (C.VarE v) = v+exprToVar e = error $ "Style expression matching does not yet handle nested expressions: '" ++ show e ++ "'"++findType :: VarEnv -> String -> [T]+findType typeEnv name =+ case M.lookup name (valConstructors typeEnv) of+ Just vc -> tlsvc vc ++ [tvc vc]+ Nothing -> error $ "name '" ++ name ++ "' does not exist in Substance val constructor environment"+ -- shouldn't happen, since the Sub/Sty should have been statically checked)++exprsMatchArr :: VarEnv -> C.Func -> C.Func -> Bool+exprsMatchArr typeEnv subE styE =+ let subArrType = findType typeEnv $ C.nameFunc subE+ styArrType = findType typeEnv $ C.nameFunc styE+ subVarArgs = map exprToVar $ C.argFunc subE+ styVarArgs = map exprToVar $ C.argFunc styE+ in let res = isSubtypeArrow subArrType styArrType typeEnv+ && (all (uncurry varsEq) $ zip subVarArgs styVarArgs) in+ trM1 ("subArrType: " ++ show subArrType+ ++ "\nstyArrType: " ++ show styArrType+ ++ "\nres: " ++ show (isSubtypeArrow subArrType styArrType typeEnv)) res++-- New judgment (COMBAK number): expression matching that accounts for subtyping. G, B, . |- E0 <| E1+-- We assume the latter expression has already had a substitution applied+exprsMatch :: VarEnv -> C.Expr -> C.Expr -> Bool+-- rule Match-Expr-Var+exprsMatch typeEnv (C.VarE subVar) (C.VarE styVar) = varsEq subVar styVar++-- Match value constructor applications if one val ctor is a subtype of another+-- whereas for function applications, we match only if the exprs are equal (for now)+-- This is because a val ctor doesn't "do" anything besides wrap its values+-- whereas functions with the same type could do very different things, so we don't+-- necessarily want to match them by subtyping+-- (e.g. think of the infinite functions from Vector -> Vector)+-- rule Match-Expr-Vconsapp+exprsMatch typeEnv (C.ApplyValCons subE) (C.ApplyValCons styE) =+ exprsMatchArr typeEnv subE styE+-- rule Match-Expr-Fnapp+exprsMatch typeEnv (C.ApplyFunc subE) (C.ApplyFunc styE) =+ subE == styE+exprsMatch _ _ _ = False++-- Judgment 11. b; theta |- S <| |S_r+relMatchesLine :: VarEnv -> C.SubEnv -> C.SubStmt -> RelationPattern -> Bool+-- rule Bind-Match+relMatchesLine typeEnv subEnv s1@(C.Bind var expr) s2@(RelBind bvar sExpr) =+ case bvar of+ BStyVar v -> error ("Style variable '" ++ show v ++ "' found in relational statement '" ++ show (RelBind bvar sExpr) ++ "'. Should not be present!")+ BSubVar sVar ->+ let selExpr = toSubExpr sExpr in+ let res = (varsEq var sVar && exprsMatch typeEnv expr selExpr)+ || C.exprsDeclaredEqual subEnv expr selExpr -- B |- E = |E+ in trM1 ("trying to match exprs \n'" ++ show s1 ++ "'\n'" ++ show s2 ++ "'\n\n") $ res++-- rule Pred-Match+relMatchesLine typeEnv subEnv (C.ApplyP pred) (RelPred sPred) =+ let selPred = toSubPred sPred in+ C.predsEq pred selPred -- self-equal+ || C.predsDeclaredEqual subEnv pred selPred -- B |- Q <-> |Q+relMatchesLine _ _ _ _ = False -- no other line forms match each other (decl, equality, etc.)++-- Judgment 13. b |- [S] <| |S_r+relMatchesProg :: VarEnv -> C.SubEnv -> C.SubProg -> RelationPattern -> Bool+relMatchesProg typeEnv subEnv subProg rel = any (flip (relMatchesLine typeEnv subEnv) rel) subProg++-- Judgment 15. b |- [S] <| [|S_r]+allRelsMatch :: VarEnv -> C.SubEnv -> C.SubProg -> [RelationPattern] -> Bool+allRelsMatch typeEnv subEnv subProg rels = all (relMatchesProg typeEnv subEnv subProg) rels++-- Optimization to filter out Substance statements that have no hope of matching any of the substituted relation patterns, so we don't do redundant work for every substitution (of which there could be millions). This function is only called once per selector.+couldMatchRels :: VarEnv -> [RelationPattern] -> C.SubStmt -> Bool+couldMatchRels typeEnv rels stmt = any (flip couldMatchARel stmt) rels+ where couldMatchARel :: RelationPattern -> C.SubStmt -> Bool+ -- Heuristic: check if names are equal+ couldMatchARel (RelBind _ (SEAppFunc styF _)) (C.Bind _ (C.ApplyFunc subF)) =+ styF == C.nameFunc subF++ couldMatchARel (RelBind _ (SEAppValCons styVC _)) (C.Bind _ (C.ApplyValCons subVC')) =+ let subVC = C.nameFunc subVC' in+ styVC == subVC+ || isSubtypeArrowNamed typeEnv subVC styVC -- check value ctor subtyping++ couldMatchARel (RelPred styPred) (C.ApplyP subPred) =+ predicateName styPred == (nameOf $ C.predicateName subPred)++ couldMatchARel _ _ = False++ nameOf (C.PredicateConst n) = n++isSubtypeArrowNamed :: VarEnv -> String -> String -> Bool+isSubtypeArrowNamed typeEnv subCtor styCtor =+ let subArrType = findType typeEnv subCtor+ styArrType = findType typeEnv styCtor+ in isSubtypeArrow subArrType styArrType typeEnv++-- Judgment 17. b; [theta] |- [S] <| [|S_r] ~> [theta']+-- Folds over [theta]+filterRels :: VarEnv -> C.SubEnv -> C.SubProg -> [RelationPattern] -> [Subst] -> [Subst]+filterRels typeEnv subEnv subProg rels substs =+ let subProgFiltered = filter (couldMatchRels typeEnv rels) subProg in+ -- trace ("\n----------\n\nrels:\n" ++ ppShow rels+ -- ++ "\nsub prog filtered\n: " ++ ppShow subProgFiltered) $+ filter (\subst -> allRelsMatch typeEnv subEnv subProgFiltered + (substituteRels subst rels)) substs++----- Match declaration statements++-- Judgment 9. G; theta |- T <| |T+-- Assumes types are nullary, so doesn't return a subst, only a bool indicating whether the types matched+matchType :: VarEnv -> T -> StyT -> Bool+matchType varEnv substanceType@(TConstr tctor) styleType@(STCtor stctor) =+ if not (null (argCons tctor)) || not (null (argConsS stctor))+ then error "no types with parameters allowed in match" -- TODO error msg+ else trM1 ("types: " ++ nameCons tctor ++ ", " ++ nameConsS stctor) $+ nameCons tctor == nameConsS stctor+ -- Only match if a Substance type is a subtype of a Style type (e.g. Interval matches ClosedInterval)+ || isSubtype substanceType (toSubType styleType) varEnv+-- TODO better errors + think about cases below+matchType varEnv (TTypeVar tvar) (STTypeVar stvar) = error "no type vars allowed in match"+matchType varEnv (TConstr tvar) (STTypeVar stvar) = error "no type vars allowed in match"+matchType varEnv (TTypeVar tvar) (STCtor stctor) = error "no type vars allowed in match"++-- Judgment 10. theta |- x <| B+matchBvar :: Var -> BindingForm -> Maybe Subst+matchBvar subVar (BStyVar styVar) = Just $ M.insert styVar subVar M.empty+matchBvar subVar (BSubVar styVar) = if subVar == styVar+ then Just M.empty+ else Nothing++-- Judgment 12. G; theta |- S <| |S_o+matchDeclLine :: VarEnv -> C.SubStmt -> DeclPattern -> Maybe Subst+matchDeclLine varEnv (C.Decl subT subVar) (PatternDecl' styT bvar) =+ let typesMatched = matchType varEnv subT styT in+ if typesMatched+ then trM1 "types matched" $ matchBvar subVar bvar+ else trM1 "types didn't match" Nothing -- substitution is only valid if types matched first+matchDeclLine _ subL styL = Nothing -- Sty decls only match Sub decls++-- Judgment 16. G; [theta] |- [S] <| [|S_o] ~> [theta']+matchDecl :: VarEnv -> C.SubProg -> [Subst] -> DeclPattern -> [Subst]+matchDecl varEnv subProg initSubsts decl =+ -- Judgment 14. G; [theta] |- [S] <| |S_o+ let newSubsts = map (flip (matchDeclLine varEnv) decl) subProg in+ trM1 ("new substs: " ++ show newSubsts) $ merge initSubsts (catMaybes newSubsts)+ -- TODO: why is this trace necessary to see the rest of the debug output?+ -- is it because of list comprehensions?++-- Judgment 18. G; [theta] |- [S] <| [|S_o] ~> [theta']+-- Folds over [|S_o]+matchDecls :: VarEnv -> C.SubProg -> [DeclPattern] -> [Subst] -> [Subst]+matchDecls varEnv subProg decls initSubsts = foldl (matchDecl varEnv subProg) initSubsts decls++----- Overall judgments++find_substs_sel :: VarEnv -> C.SubEnv -> C.SubProg -> (Header, SelEnv) -> [Subst]+-- Judgment 19. g; G; b; [theta] |- [S] <| Sel+-- NOTE: this uses little gamma (not in paper) to check substitution validity+find_substs_sel varEnv subEnv subProg (Select sel, selEnv) =+ let decls = selHead sel ++ selWith sel+ rels = selWhere sel+ initSubsts = []+ rawSubsts = matchDecls varEnv subProg decls initSubsts+ subst_candidates = filter (fullSubst selEnv)+ $ trace ("rawSubsts: # " ++ show (length rawSubsts))+ rawSubsts+ -- TODO: check validity of subst_candidates (all StyVars have exactly one SubVar)+ filtered_substs = trM1 ("candidates: " ++ show subst_candidates) $+ filterRels varEnv subEnv subProg rels subst_candidates+ correct_substs = filter uniqueKeysAndVals filtered_substs+ in correct_substs+find_substs_sel _ _ _ (Namespace _, _) = [] -- No substitutions for a namespace (not in paper)++-- TODO: add note on prog, header judgment to paper?+-- Find a list of substitutions for each selector in the Sty program.+find_substs_prog :: VarEnv -> C.SubEnv -> C.SubProg -> StyProg -> [SelEnv] -> [[Subst]]+find_substs_prog varEnv subEnv subProg styProg selEnvs =+ let sels = map fst styProg in+ let selsWithEnvs = zip sels selEnvs in+ map (find_substs_sel varEnv subEnv subProg) selsWithEnvs++-- TODO: make anonymous variables for unification for Substance program++-------------------- Translation dynamics (i.e. actual Style compiler)++-- TODO: block statics+checkBlock :: SelEnv -> Block -> [Error]+checkBlock selEnv block = []++----- Type definitions+type GPICtor = String++data TagExpr a = OptEval Expr -- ^ Thunk evaluated at each step of optimization-time+ | Done (Value a) -- ^ A value in the host language, fully evaluated+ | Pending (Value a) -- ^ A value to be updated afterwards (e.g. label dimensions)+ deriving (Show, Eq, Typeable)++type PropertyDict a = M.Map Property (TagExpr a)+type FieldDict a = M.Map Field (FieldExpr a)++data FieldExpr a = FExpr (TagExpr a)+ | FGPI ShapeTypeStr (PropertyDict a)+ deriving (Show, Eq, Typeable)++type Warning = String+data Name = Sub String -- Sub obj name+ | Gen String -- randomly generated name+ deriving (Show, Eq, Ord, Typeable)++data Translation a = Trans { trMap :: M.Map Name (FieldDict a),+ warnings :: [Warning] }+ deriving (Show, Eq, Typeable)++type OverrideFlag = Bool++-- For a Substance object "A", the Translation might look like this:+-- Trans [ "A" =>+-- FieldDict [ "val" => FExpr (Done (IntLit 2)),+-- "shape" => GPI Circ PropMap [ "r" => OptEval (EPath (FieldPath (SubVar (VC "B"))) "val"),+-- "x" => ... ] ] ]++----- Translation util functions++initTrans :: forall a . Autofloat a => Translation a+initTrans = Trans { trMap = M.empty, warnings = [] }++-- Convert Sub bvar name to Sub name in Translation+trName :: BindingForm -> Name+trName (BSubVar (VarConst nm)) = Sub nm+trName (BStyVar (StyVar' nm)) = Sub nm+ -- error ("Style variable '" ++ show bv ++ "' in block! Was a non-full substitution applied?") -- TODO/URGENT fix for namespaces++nameStr :: Name -> String+nameStr (Sub s) = s+nameStr (Gen s) = s++mkPropertyDict :: (Autofloat a) => [PropertyDecl] -> PropertyDict a+mkPropertyDict propertyDecls = foldl addPropertyDecl M.empty propertyDecls+ where addPropertyDecl :: PropertyDict a -> PropertyDecl -> PropertyDict a+ -- TODO: check that the same property is not declared twice+ addPropertyDecl dict (PropertyDecl property expr) = M.insert property (OptEval expr) dict++-- All warnings are appended+addMaybe :: [a] -> Maybe a -> [a]+addMaybe xs x = xs ++ maybeToList x++addMaybes :: [a] -> [Maybe a] -> [a]+addMaybes xs ms = xs ++ catMaybes ms++addWarn :: Translation a -> Warning -> Translation a+addWarn tr warn = tr { warnings = warnings tr ++ [warn] }++-- TODO clean these up+pathStr :: Path -> String+pathStr (FieldPath bvar field) = intercalate "." [show bvar, field]+pathStr (PropertyPath bvar field property) = intercalate "." [show bvar, field, property]++pathStr2 :: Name -> Field -> String+pathStr2 name field = intercalate "." [nameStr name, field]++pathStr3 :: Name -> Field -> Property -> String+pathStr3 name field property = intercalate "." [nameStr name, field, property]++----- Main operations on translations (add and delete)++-- TODO distinguish between warns/errs+deleteField :: (Autofloat a) => Translation a -> Name -> Field -> Translation a+deleteField trans name field =+ let trn = trMap trans in+ case M.lookup name trn of+ Nothing ->+ let err = "Err: Sub obj '" ++ nameStr name ++ "' has no fields; can't delete field '" ++ field ++ "'" in+ addWarn trans err+ Just fieldDict ->+ if field `M.notMember` fieldDict+ then let warn = "Warn: Sub obj '" ++ nameStr name ++ "' already lacks field '" ++ field ++ "'" in+ addWarn trans warn+ else let fieldDict' = M.delete field fieldDict+ trn' = M.insert name fieldDict' trn in+ trans { trMap = trn' }++deleteProperty :: (Autofloat a) => Translation a -> Name -> Field -> Property -> Translation a+deleteProperty trans name field property =+ let trn = trMap trans+ path = pathStr3 name field property in+ case M.lookup name trn of+ Nothing ->+ let err = "Err: Sub obj '" ++ nameStr name ++ "' has no fields; can't delete path '" ++ path ++ "'" in+ addWarn trans err+ Just fieldDict ->+ case M.lookup field fieldDict of+ Nothing -> let err = "Err: Sub obj '" ++ nameStr name ++ "' already lacks field '" ++ field+ ++ "'; can't delete path " ++ path in+ addWarn trans err+ -- Deal with path aliasing as in `addProperty`+ Just (FExpr e) ->+ case e of+ OptEval (EPath p@(FieldPath bvar newField)) ->+ let newName = trName bvar in+ if newName == name && newField == field+ then let err = "Error: path '" ++ pathStr p ++ "' was aliased to itself"+ in addWarn trans err+ else deleteProperty trans newName newField property+ res -> let err = "Error: Sub obj '" ++ nameStr name ++ "' does not have GPI '"+ ++ field ++ "'; cannot delete property '" ++ property ++ "'" in+ addWarn trans err+ Just (FGPI ctor properties) ->+ -- If the field is GPI, check if property already exists+ if property `M.notMember` properties+ then let warn = "Warning: property '" ++ property ++ "' already does not exist in path '"+ ++ pathStr3 name field property ++ "'; deletion does nothing"+ in addWarn trans warn+ else let properties' = M.delete property properties+ fieldDict' = M.insert field (FGPI ctor properties') fieldDict+ trn' = M.insert name fieldDict' trn in+ trans { trMap = trn' }++-- Implements two rules for fields:+-- x.n = Ctor { n_i = e_i }, rule Line-Set-Ctor, for GPI+-- x.n = e, rule Line-Set-Field-Expr+addField :: (Autofloat a) => OverrideFlag -> Translation a ->+ Name -> Field -> TagExpr a -> Translation a+addField override trans name field texpr =+ let trn = trMap trans in+ let fieldDict = case M.lookup name trn of+ Nothing -> M.empty -- Initialize the field dict if it hasn't been initialized+ Just fdict -> fdict in+ -- Warn using override if x doesn't exist+ let warn1 = if fieldDict == M.empty && override+ then Just $ "Warning: Sub obj '" ++ nameStr name ++ "' has no fields, but override was declared"+ else Nothing in+ -- Warn using override if x.n already exists+ let warn2 = if (field `M.member` fieldDict) && (not override)+ then Just $ "Warning: Sub obj '" ++ nameStr name ++ "''s field '" ++ field+ ++ "' is overridden, but was not declared an override"+ else Nothing in+ -- Warn using override if x.n doesn't exist+ let warn3 = if (field `M.notMember` fieldDict) && override+ then Just $ "Warning: field '" ++ field ++ "' declared override, but has not been initialized"+ else Nothing in+ -- TODO: check existing FExpr is overridden by an FExpr and likewise for Ctor of same type (typechecking)+ let fieldExpr = case texpr of+ OptEval (Ctor ctorName propertyDecls) -> -- rule Line-Set-Ctor+ FGPI ctorName (mkPropertyDict propertyDecls)+ _ -> FExpr texpr in -- rule Line-Set-Field-Expr+ let fieldDict' = M.insert field fieldExpr fieldDict+ trn' = M.insert name fieldDict' trn in+ trans { trMap = trn', warnings = addMaybes (warnings trans) [warn1, warn2, warn3] }++addProperty :: (Autofloat a) => OverrideFlag -> Translation a ->+ Name -> Field -> Property -> TagExpr a -> Translation a+addProperty override trans name field property texpr =+ let trn = trMap trans in+ -- Setting a field's property should require that field to already exist and be a GPI+ -- TODO: distinguish b/t errors and warns+ case M.lookup name trn of+ Nothing -> let err = "Error: Sub obj '" ++ nameStr name ++ "' has no fields; cannot add property" in+ addWarn trans err+ Just fieldDict ->+ case M.lookup field fieldDict of+ Nothing -> let err = "Error: Sub obj '" ++ nameStr name ++ "' does not have field '"+ ++ field ++ "'; cannot add property '" ++ property ++ "'" in+ addWarn trans err+ -- If looking up "f.domain" yields a *different* path (i.e. that path was an alias)+ -- e.g. "f.domain" is aliased to "I.shape"+ -- then call addProperty with the other path, otherwise fail+ Just (FExpr e) ->+ case e of+ OptEval (EPath p@(FieldPath bvar newField)) ->+ let newName = trName bvar in+ if newName == name && newField == field+ then let err = "Error: path '" ++ pathStr p ++ "' was aliased to itself"+ in addWarn trans err+ else addProperty override trans newName newField property texpr+ res -> let err = "Error: Sub obj '" ++ nameStr name ++ "' does not have GPI '"+ ++ field ++ "'; found expr '" ++ show res ++ "'; cannot add property '" ++ property ++ "'" in+ addWarn trans err+ Just (FGPI ctor properties) ->+ -- If the field is GPI, check if property already exists and whether it matches the override setting+ let warn = if (property `M.notMember` properties) && override+ then Just $ "Warning: property '" ++ property ++ "' does not exist in path '"+ ++ pathStr3 name field property ++ "' but override was set"+ else if property `M.member` properties && (not override)+ then Just $ "Warning: property '" ++ property ++ "' already exists in path '"+ ++ pathStr3 name field property ++ "' but override was not set"+ else Nothing in+ let properties' = M.insert property texpr properties+ fieldDict' = M.insert field (FGPI ctor properties') fieldDict+ trn' = M.insert name fieldDict' trn in+ trans { trMap = trn', warnings = addMaybe (warnings trans) warn }++-- rule Line-Delete+deletePath :: (Autofloat a) => Translation a -> Path -> Either [Error] (Translation a)+deletePath trans path =+ case path of+ FieldPath bvar field ->+ let name = trName bvar+ trans' = deleteField trans name field in+ Right trans'+ PropertyPath bvar field property ->+ let name = trName bvar+ trans' = deleteProperty trans name field property in+ Right trans'++addPath :: (Autofloat a) => OverrideFlag -> Translation a -> Path -> TagExpr a -> Either [Error] (Translation a)+addPath override trans path expr =+ case path of+ -- rule Line-Set-Field-Expr, Line-Set-Ctor+ FieldPath bvar field ->+ let name = trName bvar+ trans' = addField override trans name field expr in+ Right trans'+ -- rule Line-Set-Prop-Expr+ PropertyPath bvar field property ->+ let name = trName bvar+ trans' = addProperty override trans name field property expr in+ Right trans'++----- Translation judgments++{- Note: All of the folds below use foldM.+ foldM stops accumulating when the first fatal error is reached, using "Either [Error]" as a monad+ (Non-fatal errors are stored as warnings in the translation)+ foldM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a+ example:+ f acc elem = if elem < 0 then Left ["wrong " ++ show elem] else Right $ elem : acc+ foldM f [] [1, 9, -1, 2, -2] = Left ["wrong -1"]+ foldM f [] [1, 9] = Right [9,1] -}++-- Judgment 26. D |- phi ~> D'+-- This is where interesting things actually happen (each line is interpreted and added to the translation)+translateLine :: (Autofloat a) => Translation a -> Stmt -> Either [Error] (Translation a)+translateLine trans stmt =+ case stmt of+ Assign path expr -> addPath False trans path (OptEval expr)+ Override path expr -> addPath True trans path (OptEval expr)+ Delete path -> deletePath trans path++-- Judgment 25. D |- |B ~> D' (modified to be: theta; D |- |B ~> D')+translateBlock :: (Autofloat a) => (Block, Int) -> Translation a -> (Subst, Int) ->+ Either [Error] (Translation a)+translateBlock blockWithNum trans substNum =+ let block' = substituteBlock substNum blockWithNum in+ foldM translateLine trans block'++-- Judgment 24. [theta]; D |- |B ~> D'+translateSubstsBlock :: (Autofloat a) => Translation a -> [(Subst, Int)] ->+ (Block, Int) -> Either [Error] (Translation a)+translateSubstsBlock trans substsNum blockWithNum = foldM (translateBlock blockWithNum) trans substsNum++-- Judgment 23, contd.+translatePair :: (Autofloat a) => VarEnv -> C.SubEnv -> C.SubProg ->+ Translation a -> ((Header, Block), Int) -> Either [Error] (Translation a)+translatePair varEnv subEnv subProg trans ((Namespace styVar, block), blockNum) =+ let selEnv = initSelEnv+ bErrs = checkBlock selEnv block in+ if null (sErrors selEnv) && null bErrs+ then let subst = M.empty in -- is this the correct empty?+ translateBlock (block, blockNum) trans (subst, 0) -- skip transSubstsBlock; only one subst+ else Left $ sErrors selEnv ++ bErrs++translatePair varEnv subEnv subProg trans ((header@(Select sel), block), blockNum) =+ let selEnv = checkSel varEnv sel+ bErrs = checkBlock selEnv block in+ if null (sErrors selEnv) && null bErrs+ then let substs = find_substs_sel varEnv subEnv subProg (header, selEnv) in+ let numberedSubsts = zip substs [0..] in -- For creating unique local var names+ translateSubstsBlock trans numberedSubsts (block, blockNum)+ else Left $ sErrors selEnv ++ bErrs++insertLabels :: (Autofloat a, Eq a) => Translation a -> C.LabelMap -> Translation a+insertLabels trans labels =+ trans { trMap = M.mapWithKey insertLabel (trMap trans),+ warnings = warnings trans ++ ["Note: Text GPIs are automatically deleted if their Substance object has no label"]+ -- TODO: print out the names of the GPIs that were auto-deleted+ }+ where+ toFieldStr :: Eq a => String -> FieldExpr a+ toFieldStr s = FExpr $ Done $ StrV s++ insertLabel :: Eq a => Name -> FieldDict a -> FieldDict a+ insertLabel (Sub s) fieldDict = + let labelField = "label" in+ case M.lookup s labels of+ Nothing -> fieldDict+ -- NOTE: maybe this is a "namespace," so we pass through+ Just (Just l) -> M.insert labelField (toFieldStr l) fieldDict+ -- If "NoLabel", default to an empty string *and* delete any Text GPIs that use it+ Just Nothing -> let fd' = M.insert labelField (toFieldStr "") fieldDict in+ M.filter (not . usesLabelText s) fd'+ -- only insert labels for Substance objects+ insertLabel (Gen _) fieldDict = fieldDict++ -- Return True if it's a Text GPI that uses the label+ -- TODO: should probably do something with other GPIs/fields that use the label (delete/filter/modify them?)+ -- as well as recursively delete anything else that refers to *those* things+ usesLabelText :: Eq a => String -> FieldExpr a -> Bool+ usesLabelText subName (FExpr _) = False+ usesLabelText subName (FGPI shapeType properties) =+ let labelForm = OptEval (EPath (FieldPath (BSubVar (VarConst subName)) "label"))+ usesLabel = case M.lookup "string" properties of+ Nothing -> False+ Just expr -> expr == labelForm+ in shapeType == "Text" && usesLabel++-- For any Substance object (say one called "K1"), insert the field mapping `K1.name = "K1"` which will be accessible from Style.+-- This is generally for plugin accessors to use in Style, so they can access the right field of the Style values returned by a plugin.+insertNames :: (Autofloat a, Eq a) => Translation a -> Translation a+insertNames trans = trans { trMap = M.mapWithKey insertName $ trMap trans }+ where insertName :: Name -> FieldDict a -> FieldDict a -- I guess we don't need to insert names for namespaces+ insertName (Sub name) fieldDict = + let nameField = "name" in+ M.insert nameField (FExpr $ Done $ StrV name) fieldDict+ insertName (Gen _) fieldDict = fieldDict+ +{- Find plugin accessor expressions+Evaluates a plugin accessor’s subexpressions (the primary and secondary key)+ Static evaluate: look up value in translation (perform compile-time computations)+ Check their types (both need to be strings)+Look up the result in the plugin’s JSON output+Store it in the translation in place of the accessor, as a finished float -}+ +evalPluginAccess :: (Autofloat a) => StyValMap a -> Translation a -> Translation a+evalPluginAccess valMap trans = + trans { trMap = M.mapWithKey (evalFieldAccesses valMap) $ trMap trans }++ where evalFieldAccesses :: (Autofloat a) => StyValMap a -> Name -> FieldDict a -> FieldDict a+ evalFieldAccesses vmap (Sub name) fieldDict = + M.mapWithKey (evalFieldAccess vmap) fieldDict+ evalFieldAccesses vmap (Gen _) fieldDict = fieldDict++ evalFieldAccess :: (Autofloat a) => StyValMap a -> Field -> FieldExpr a -> FieldExpr a+ evalFieldAccess vmap field (FExpr te) = FExpr $ evalTExpr vmap te+ evalFieldAccess vmap field (FGPI stype properties) =+ let properties' = M.mapWithKey (evalPropertyAccess vmap) properties in+ FGPI stype properties'+ + evalPropertyAccess :: (Autofloat a) => StyValMap a -> Property -> TagExpr a -> TagExpr a+ evalPropertyAccess vmap property te = evalTExpr vmap te++ evalTExpr :: (Autofloat a) => StyValMap a -> TagExpr a -> TagExpr a+ evalTExpr vmap val@(Done _) = val+ evalTExpr vmap (OptEval e) = OptEval $ evalPluginExpr vmap e+ -- TODO: check if the result was a string, and if so, make it a done value?++ evalPluginExpr :: (Autofloat a) => StyValMap a -> Expr -> Expr+ -- Do work: evaluate something like ddg[A.name]["x"] by evaluating each key and looking up the result in JSON+ evalPluginExpr vmap (PluginAccess p e1 e2) = + -- TODO: actually check/use the plugin string; this currently ignores the plugin `p`+ -- just use the trans in the context of `evalPluginAccess` for now, TODO: fix to pass it around?+ -- or remove the vmap from the context+ let e1' = evalStatic e1 + e2' = evalStatic e2+ res = lookupStyVal e1' e2' vmap+ in AFloat $ Fix $ r2f res++ -- Look for work to do (might involve strings)+ evalPluginExpr vmap (CompApp s es) = CompApp s $ map (evalPluginExpr vmap) es+ evalPluginExpr vmap (ObjFn s es) = ObjFn s $ map (evalPluginExpr vmap) es+ evalPluginExpr vmap (ConstrFn s es) = ConstrFn s $ map (evalPluginExpr vmap) es+ evalPluginExpr vmap (AvoidFn s es) = AvoidFn s $ map (evalPluginExpr vmap) es+ evalPluginExpr vmap (BinOp o e1 e2) = BinOp o (evalPluginExpr vmap e1) (evalPluginExpr vmap e2)+ evalPluginExpr vmap (UOp o e) = UOp o $ evalPluginExpr vmap e+ evalPluginExpr vmap (List es) = List $ map (evalPluginExpr vmap) es+ evalPluginExpr vmap (Tuple e1 e2) = Tuple (evalPluginExpr vmap e1) (evalPluginExpr vmap e2)+ evalPluginExpr vmap (ThenOp e1 e2) = ThenOp (evalPluginExpr vmap e1) (evalPluginExpr vmap e2)++ -- Leaves (no strings should be involved)+ evalPluginExpr _ e@(IntLit _) = e+ evalPluginExpr _ e@(AFloat _) = e+ evalPluginExpr _ e@(StringLit _) = e+ evalPluginExpr _ e@(BoolLit _) = e+ evalPluginExpr _ e@(EPath _) = e+ evalPluginExpr _ e@(ListAccess _ _) = e+ evalPluginExpr _ e@(Ctor _ _) = e+ evalPluginExpr _ e@(Layering _ _) = e++ evalStatic :: Expr -> String+ evalStatic (StringLit s) = s+ evalStatic (EPath (FieldPath bvar field)) = + case lookupField bvar field trans of -- TODO: clean up lookupField location+ FExpr (OptEval (StringLit s)) -> s+ FExpr (Done (StrV s)) -> s+ _ -> error "expected string for plugin accessor key; after looking up field, didn't get string"+ evalStatic (EPath (PropertyPath (BSubVar v) field property)) = error "plugin TODO"+ evalStatic e = error "expected string or path expression for plugin accessor key; did not get a string"++-- TODO: add beta in paper and to comment below+-- Judgment 23. G; D |- [P]; |P ~> D'+-- Fold over the pairs in the Sty program, then the substitutions for a selector, then the lines in a block.+translateStyProg :: forall a . (Autofloat a) =>+ VarEnv -> C.SubEnv -> C.SubProg -> StyProg -> C.LabelMap -> [J.StyVal] ->+ Either [Error] (Translation a)+translateStyProg varEnv subEnv subProg styProg labelMap styVals =+ let numberedProg = zip styProg [0..] in -- For creating unique local var names+ case foldM (translatePair varEnv subEnv subProg) initTrans numberedProg of+ Right trans -> + let transWithNames = insertNames trans+ transWithNamesAndLabels = insertLabels transWithNames labelMap + styValMap = styJsonToMap styVals+ transWithPlugins = evalPluginAccess styValMap transWithNamesAndLabels+ in trace "translateStyProg: " $ Right transWithPlugins+ Left errors -> Left errors++---------- Plugin accessors++type SubObjName = String+type PropertyName = String+type StyValMap a = M.Map SubObjName (M.Map PropertyName a)++styJsonToMap :: (Autofloat a) => [J.StyVal] -> StyValMap a+styJsonToMap vals = + M.fromList (map (\v -> (subName v, + M.fromList (map (\w -> (propertyName w, + r2f $ propertyVal w)) + (nameVals v)))) + vals)++-- TODO move lookups to utils; this was moved from GenOptProblem+lookupField :: (Autofloat a) => BindingForm -> Field -> Translation a -> FieldExpr a+lookupField bvar field trans =+ let name = trName bvar in+ let trn = trMap trans in+ case M.lookup name trn of+ Nothing -> error ("path '" ++ pathStr2 name field ++ "''s name doesn't exist in trans")+ -- TODO improve error messages and return error messages (Either [Error] (TagExpr a))+ Just fieldDict ->+ case M.lookup field fieldDict of+ Nothing -> error ("path '" ++ pathStr2 name field ++ "'s field doesn't exist in trans")+ Just fexpr -> fexpr+ -- TODO: This is the right way to look up fields, but doing so causes a frontend undefined error. Why?++ -- case fexpr of + -- -- Deal with field aliases, e.g. `f.codomain = R.shape`. Keep looking up paths until we get a GPI or expression.+ -- FExpr (OptEval (EPath (FieldPath bvarSynonym fieldSynonym))) ->+ -- if bvar == bvarSynonym && field == fieldSynonym+ -- then error ("nontermination in lookupField with path '" ++ pathStr2 name field ++ "' set to itself")+ -- else trace ("Recursively looking up field " ++ pathStr (FieldPath bvar field) ++ " -> " ++ pathStr (FieldPath bvarSynonym fieldSynonym)) lookupField bvarSynonym fieldSynonym trans+ -- _ -> fexpr++shapeType :: (Autofloat a) => BindingForm -> Field -> Translation a -> ShapeTypeStr+shapeType bvar field trans =+ case lookupField bvar field trans of+ FGPI stype _ -> stype+ -- -- Deal with field aliases, e.g. `f.codomain = R.shape`. Keep looking up paths until we get a GPI or expression.+ FExpr (OptEval (EPath (FieldPath bvarSynonym fieldSynonym))) ->+ if bvar == bvarSynonym && field == fieldSynonym+ then error ("nontermination in lookupField with path '" ++ pathStr (FieldPath bvar field) ++ "' set to itself")+ else {- trace ("Recursively looking up field " ++ pathStr (FieldPath bvar field) ++ " -> " ++ pathStr (FieldPath bvarSynonym fieldSynonym)) -} shapeType bvarSynonym fieldSynonym trans++ FExpr e -> error ("path " ++ show e ++ " is not a GPI; cannot get type")++lookupStyVal :: (Autofloat a) => String -> String -> StyValMap a -> a+lookupStyVal subName propName vmap =+ case M.lookup subName vmap of+ Nothing -> error ("plugin accessors in style: for access " ++ toAccess subName propName ++ ", primary key does not exist")+ Just propDict ->+ case M.lookup propName propDict of+ Nothing -> error ("plugin accessors in style: for access " ++ toAccess subName propName ++ ", property does not exist")+ Just val -> val+ where toAccess s1 s2 = s1 ++ "." ++ s2++--------------------------------------------------------------------------------+-- Debugging++-- main :: IO ()+-- main = do+-- let f = "sty/test.sty"+--+-- let elementFile = "real-analysis-domain/real-analysis.dsl"+-- elementIn <- readFile elementFile+-- elementEnv <- parseElement elementFile elementIn+--+-- prog <- readFile f+-- res <- parseInstantiation f prog elementEnv+-- print res
+ src/Substance.hs view
@@ -0,0 +1,787 @@+-- | "Substance" contains the grammar, parser, and semantic checker for+-- the Substance language. It also contains translators to Alloy and+-- the driver for it.+-- Author: Dor Ma'ayan, May 2018++{-# OPTIONS_HADDOCK prune #-}+{-# LANGUAGE FlexibleContexts #-}+module Substance where+--module Main (main) where -- for debugging purposes+-- TODO split this up + do selective export++import Control.Arrow ((>>>))+import Control.Monad (void)+import Data.List+import Data.Maybe+import Data.Typeable+import Data.Void+import Debug.Trace+import Env+import System.Environment+import System.IO+import System.Process+import System.Random+import Control.Monad.Combinators.Expr+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Show.Pretty+import Utils+import Control.Monad.State.Lazy (evalStateT, get)+-- import Text.PrettyPrint+--import Text.PrettyPrint.HughesPJClass hiding (colon, comma, parens, braces)+import qualified Data.Map.Strict as M+import qualified Element as D+import qualified Text.Megaparsec.Char.Lexer as L++---------------------------- Substance AST -------------------------------------++newtype ValConstructorName = ValConst String -- “Cons”, “Times”+ deriving (Show, Eq, Typeable)++newtype OperatorName = OperatorConst String -- “Intersection”+ deriving (Show, Eq, Typeable)++newtype PredicateName = PredicateConst String -- “Intersect”+ deriving (Show, Eq, Typeable)++newtype Field = FieldConst String -- “Intersect”+ deriving (Show, Eq, Typeable)++data Func = Func {+ nameFunc :: String,+ argFunc :: [Expr]+} deriving (Eq, Typeable)++instance Show Func where+ show (Func nameFunc argFunc) = nString ++ "(" ++ aString ++ ")"+ where nString = show nameFunc+ aString = show argFunc++data Expr = VarE Var+ | ApplyFunc Func+ | ApplyValCons Func+ | DeconstructorE Deconstructor+ deriving (Show, Eq, Typeable)++data Deconstructor = Deconstructor {+ varDeconstructor :: Var ,+ fieldDeconstructor :: Field+ } deriving (Show, Eq, Typeable)+++data PredArg = PE Expr+ | PP Predicate+ deriving (Show, Eq, Typeable)++data Predicate = Predicate { predicateName :: PredicateName,+ predicateArgs :: [PredArg],+ predicatePos :: SourcePos }+ deriving (Eq, Typeable)++instance Show Predicate where+ show (Predicate predicateName predicateArgs pos) = nString ++ "(" ++ aString ++ ")"+ where nString = show predicateName+ aString = show predicateArgs++data SubStmt = Decl T Var+ | DeclList T [Var]+ | Bind Var Expr+ | EqualE Expr Expr+ | EqualQ Predicate Predicate+ | ApplyP Predicate+ | LabelDecl Var String+ | AutoLabel LabelOption+ | NoLabel [Var]+ deriving (Show, Eq, Typeable)++data LabelOption = Default | IDs [Var]+ deriving (Show, Eq, Typeable)++-- | Program is a sequence of statements+type SubProg = [SubStmt]+type SubObjDiv = ([SubDecl], [SubConstr])++-- | 'SubOut' is the output of the Substance compuler, comprised of:+-- * Substance AST+-- * (Variable environment (?), Substance environment)+-- * A mapping from Substance ids to their coresponding labels+data SubOut = SubOut SubProg (VarEnv, SubEnv) LabelMap+instance Show SubOut where+ show (SubOut subProg (subEnv, eqEnv) labelMap) =+ "Parsed Substance program:\n"+++ ppShow subProg +++ "\nSubstance type env:\n" +++ ppShow subEnv +++ "\nSubstance dyn env:\n" +++ ppShow eqEnv +++ "\nLabel mappings:\n" +++ ppShow labelMap++------------------------------------+-- | Special data types for passing on to the style parser++-- | Declaration of Substance objects+data SubDecl = SubDeclConst T Var+ deriving (Show, Eq, Typeable)++-- | Declaration of Substance constaints+data SubConstr = SubConstrConst String [PredArg]+ deriving (Show, Eq, Typeable)++-- | Both declarations and constaints in Substance are regarded as objects,+-- which is possible for Style to select later.+data SubObj = LD SubDecl+ | LC SubConstr+ deriving (Show, Eq, Typeable)++--------------------------------------- Substance Parser --------------------------------------++refineAST :: SubProg -> VarEnv -> SubProg+refineAST subProg varEnv =+ let subProg' = map preludesToDeclarations (preludes varEnv) ++ subProg+ in foldl refineDeclList [] subProg'++refineDeclList accumProg (DeclList t vars) =+ accumProg ++ foldl (convertDeclList t) [] vars+refineDeclList accumProg stmt = accumProg ++ [stmt]++convertDeclList t vars var = vars ++ [Decl t var]++-- | Convert prelude statemnts from the .dsl file into declaration Statements+-- in the Substance program AST+preludesToDeclarations :: (Var,T) -> SubStmt+preludesToDeclarations (v,t) = (Decl t v)+++-- | 'substanceParser' is the top-level parser function. The parser contains a list of functions+-- that parse small parts of the language. When parsing a source program, these functions are invoked in a top-down manner.+substanceParser :: VarEnv -> BaseParser [SubStmt]+substanceParser env = evalStateT substanceParser' $ Just env+substanceParser' = between scn eof subProg -- Parse all the statemnts between the spaces to the end of the input file++-- |'subProg' parses the entire actual Substance Core language program which is a collection of statements+subProg :: Parser [SubStmt]+subProg = subStmt `sepEndBy` newline'++predicateNameParser :: Parser PredicateName+predicateNameParser = PredicateConst <$> identifier++functionParser :: Parser Func+functionParser = do+ n <- identifier+ args <- parens (exprParser `sepBy1` comma)+ return Func { nameFunc = n, argFunc = args }++fieldParser :: Parser Field+fieldParser = FieldConst <$> identifier++exprParser, varE, valConsOrFunc, deconstructorE :: Parser Expr+exprParser = try deconstructorE <|> try valConsOrFunc <|> try varE+deconstructorE = do+ v <- varParser+ dot+ f <- fieldParser+ return (DeconstructorE Deconstructor { varDeconstructor = v,+ fieldDeconstructor = f })+varE = VarE <$> varParser+valConsOrFunc = do+ n <- identifier+ e <- get+ let env = fromMaybe (error "Substance parser: variable environment is not intiialized.") e+ args <- parens (exprParser `sepBy1` comma)+ case (M.lookup n $ valConstructors env, M.lookup n $ operators env) of+ -- the id is a value constructor+ (Just _, Nothing) -> return (ApplyValCons Func { nameFunc = n, argFunc = args })+ -- the id is an operator+ (Nothing, Just _) -> return (ApplyFunc Func { nameFunc = n, argFunc = args })+ (Nothing, Nothing) -> substanceErr $ "undefined identifier " ++ n+ _ -> substanceErr $ n ++ " cannot be both a value constructor and an operator"+ where substanceErr s = customFailure (SubstanceError s)++predicateArgParser, predicateArgParserE, predicateArgParserP :: Parser PredArg+predicateArgParser = try predicateArgParserE <|> predicateArgParserP+predicateArgParserE = PE <$> exprParser+predicateArgParserP = PP <$> predicateParser++predicateParser :: Parser Predicate+predicateParser = do+ n <- predicateNameParser+ args <- parens (predicateArgParser `sepBy1` comma)+ pos <- getSourcePos+ return Predicate { predicateName = n, predicateArgs = args, predicatePos = pos }++subStmt, decl, bind, applyP, labelDecl, autoLabel, noLabel :: Parser SubStmt+subStmt = tryChoice [+ labelDecl,+ autoLabel,+ noLabel,+ equalE,+ equalQ,+ bind,+ decl,+ applyP+ ]++decl = do t' <- tParser+ vars <- varParser `sepBy1` comma+ if length vars == 1+ then return (Decl t' (head vars))+ else return (DeclList t' vars)++bind = do+ v' <- varParser+ rword ":="+ Bind v' <$> exprParser+equalE = do+ e1 <- exprParser+ eq+ EqualE e1 <$> exprParser+equalQ = do+ q1 <- predicateParser+ rword "<->"+ EqualQ q1 <$> predicateParser+applyP = ApplyP <$> predicateParser+labelDecl = do+ rword "Label"+ i <- identifier+ LabelDecl (VarConst i) <$> texExpr+noLabel = rword "NoLabel" >> NoLabel <$> ids+ where ids = map VarConst <$> identifier `sepBy1` comma+autoLabel = rword "AutoLabel" >> AutoLabel <$> (defaultLabels <|> idList)+ where idList = IDs . map VarConst <$> identifier `sepBy1` comma+ defaultLabels = Default <$ rword "All"++----------------------------------- Utility functions ------------------------------------------++-- Equality functions that don't compare SourcePos+-- TODO: use correct equality comparison in typechecker+predsEq :: Predicate -> Predicate -> Bool+predsEq p1 p2 = predicateName p1 == predicateName p2 && predicateArgs p1 == predicateArgs p2++----------------------------------------- Substance Typechecker ---------------------------++-- | 'check' is the top level function for checking a substance program which calls checkSubStmt on each statement in the+-- program and returnsan updated context from the statement check.+-- Errors are accumulated in the context during checking as they occur.+check :: SubProg -> VarEnv -> VarEnv+check p varEnv = let env = foldl checkSubStmt varEnv p+ in if null (errors env)+ then env+ else error $ "Substance type checking failed with the following problems: \n" ++ errors env++-- | Statements are checked differently depending on if they are a variable declaration, variable assignment, or predicate statement.+-- Variable declaration statements call checkT to check that the type in the statement is well-formed.+-- The context is updated with errors and the declared variable.+-- A variable assignment statement calls checkVarE and checkExpression to check both the variable and expression in the statement for well-typedness.+-- These functions return a Maybe type of the variable or expression and a string of errors (which may be empty).+-- The error strings are added to the context and the Maybe types are checked for “non-null”+-- values and then equivalence (extra error added to context if the types are not the same for the variable and expression in the statement).+-- Predicate statements are checked by checkPredicate and return a context updated with errors from that checking (if they occur).+checkSubStmt :: VarEnv -> SubStmt -> VarEnv+checkSubStmt varEnv (Decl t (VarConst n)) = let env = checkT varEnv t+ env1 = addDeclaredName n env+ in env1 { varMap = M.insert (VarConst n) t $ varMap env1 }++checkSubStmt varEnv (Bind v e) = let (vstr, vt) = checkVarE varEnv v+ (estr, et) = checkExpression varEnv e -- TODO: Check lazy evaluation on et+ in if isJust vt && isJust et && vt /= et+ then varEnv { errors = errors varEnv ++ vstr ++ estr ++ "Expression of type "+ ++ show et+ ++ " assigned to variable of type " ++ show vt ++ "\n"}+ else varEnv { errors = errors varEnv ++ vstr ++ estr }+checkSubStmt varEnv (EqualE expr1 expr2) = let (estr1, et1) = checkExpression varEnv expr1+ (estr2, et2) = checkExpression varEnv expr2+ in if isJust et1 && isJust et2 && et1 /= et2+ then varEnv { errors = errors varEnv ++ estr1 ++ estr2 +++ "Expression of type " ++ show et1+ ++ " attempeted to be equal to expression from type" ++ show et2 ++ "\n"}+ else varEnv { errors = errors varEnv ++ estr1 ++ estr2 }+checkSubStmt varEnv (EqualQ q1 q2) = let env1 = checkPredicate varEnv q1+ env2 = checkPredicate env1 q2+ in env2+checkSubStmt varEnv (ApplyP p) = checkPredicate varEnv p+checkSubStmt varEnv (AutoLabel (IDs vs)) =+ let es = concatMap (fst . checkVarE varEnv) vs in varEnv { errors = errors varEnv ++ es}+checkSubStmt varEnv (AutoLabel _) = varEnv -- no checking required+checkSubStmt varEnv (NoLabel ids) =+ let es = concatMap (fst . checkVarE varEnv) ids+ in varEnv { errors = errors varEnv ++ es}+checkSubStmt varEnv (LabelDecl i t) =+ let e = (fst . checkVarE varEnv) i+ in varEnv { errors = errors varEnv ++ e}+++-- | The predicate is looked up in the context; if the context doesn’t contain the predicate, then an error is added to the+-- context, otherwise it is checked differently depending on if it takes expressions or other predicates as arguments by+-- calling checkVarPred or checkRecursePred respectively. Any errors found within those checking functions will be accumulated+-- in the context returned by those functions and ultimately this function.+checkPredicate :: VarEnv -> Predicate -> VarEnv+checkPredicate varEnv (Predicate (PredicateConst p) args pos) =+ case checkAndGet p (predicates varEnv) pos of+ Right p -> case p of+ Pred1 p1 -> checkVarPred varEnv args p1+ Pred2 p2 -> checkRecursePred varEnv args+ Left err -> varEnv { errors = errors varEnv ++ err }+++areAllArgTypes = foldl (\b at1 -> b && isJust at1) True++++-- First, this function ensures all the supplied predicate arguments are in fact expressions using isVarPredicate.+-- If they are not, then an execution stopping error is thrown (the error is not in the checking of the program)+-- These expressions are checked by checkExpression for well-typedness returning a list of error strings and Maybe types.+-- The Maybe types list is checked for all “non-null” types.+-- If even one type is “null”, then there were checking failures and the error string is added to the context.+-- Otherwise, the error string is empty and type substitution “sigma” is generated from calling the substitution+-- function on the predicate argument types and formal types stored in the context.+-- The substitution need not be applied to any types for predicates, because using the argument types to create the+-- substitution ensures the argument types match the substitution applied to each formal type.+checkVarPred :: VarEnv -> [PredArg] -> Predicate1 -> VarEnv+checkVarPred varEnv args (Prd1 name yls kls tls) =+ let exprArgs = map isVarPredicate args+ errAndTypesLs = map (checkExpression varEnv) exprArgs+ errls = firsts errAndTypesLs+ err = concat errls+ argTypes = seconds errAndTypesLs+ in if areAllArgTypes argTypes+ then let argTypes2 = map (KT . fromJust) argTypes+ tls2 = map KT tls+ (sigma , substErr) = subst varEnv M.empty argTypes2 tls2+ in varEnv { errors = errors varEnv ++ err ++ substErr} -- err should be empty str+ else+ varEnv { errors = errors varEnv ++ err}++checkVarOperator :: VarEnv -> [PredArg] -> Env.Operator -> VarEnv+checkVarOperator varEnv args (Operator name yls kls tls _) =+ let exprArgs = map isVarPredicate args+ errAndTypesLs = map (checkExpression varEnv) exprArgs+ errls = firsts errAndTypesLs+ err = concat errls+ argTypes = seconds errAndTypesLs+ in if areAllArgTypes argTypes+ then let argTypes2 = map (KT . fromJust) argTypes+ tls2 = map KT tls+ (sigma , substErr) = subst varEnv M.empty argTypes2 tls2+ in if sigma == M.empty+ then varEnv { errors = errors varEnv ++ err ++ substErr} -- err should be empty str+ else varEnv { errors = errors varEnv ++ err ++ substErr} -- err should be empty str+ else+ varEnv { errors = errors varEnv ++ err}++-- Helper function to determine if predicate arguments are all expressions.+-- It will stop execution if a supplied predicate argument to the function is not an expression.+isVarPredicate :: PredArg -> Expr+isVarPredicate (PP p) = error "Mixed predicate types!"+isVarPredicate (PE p) = p++-- Helper function to determine if predicate arguments are all predicates.+-- It will stop execution if a supplied predicate argument to the function is not a predicate.+isRecursedPredicate :: PredArg -> Predicate+isRecursedPredicate (PP p) = p+isRecursedPredicate (PE p) = error "Mixed predicate types!"++-- This function, first, ensures all the supplied predicate arguments are predicates.+-- It calls checkPredicate (recursively) on each argument predicate returning the context with any accumulated errors found+-- when checking each argument predicate for well-formedness (if there are any).+checkRecursePred :: VarEnv -> [PredArg] -> VarEnv+checkRecursePred varEnv args = let predArgs = map isRecursedPredicate args+ in foldl checkPredicate varEnv predArgs++-- This function checks expressions for well-typedness and does it differently for variables or functions/value constructors+-- calling checkVarE and checkFunc respectively for each case.]+-- If errors were found during checking then they are accumulated and returned in a tuple with the Maybe type for the expression.+checkExpression :: VarEnv -> Expr -> (String, Maybe T)+checkExpression varEnv (VarE v) = checkVarE varEnv v+checkExpression varEnv (ApplyFunc f) = checkFunc varEnv f+checkExpression varEnv (ApplyValCons f) = checkFunc varEnv f+checkExpression varEnv (DeconstructorE d) = --checkVarE varEnv (varDeconstructor d)+ let (err, t) = checkVarE varEnv (varDeconstructor d)+ in case t of+ Just t' -> checkField varEnv (fieldDeconstructor d) t'+ Nothing -> (err, Nothing)++-- Type checking for fields in value deconstructor, check that there is a+-- matched value deconstructor with a matching field a retrieve the type,+-- otherwise, return an error+checkField :: VarEnv -> Field -> T -> (String, Maybe T)+checkField varEnv (FieldConst f) t =+ case M.lookup t (typeValConstructor varEnv) of+ Nothing -> ("No matching value constructor for the type " ++ show t, Nothing)+ Just v -> let m = M.fromList (zip (nsvc v) (tlsvc v))+ in case M.lookup (VarConst f) m of+ Nothing -> ("No matching field " ++ show f ++ " In the value constructor of " ++ show t, Nothing)+ Just t' -> ("", Just t')++-- Checking a variable expression for well-typedness involves looking it up in the context.+-- If it cannot be found in the context, then a tuple is returned of a non-empty error string warning of this problem and+-- a “null” type. Otherwise, a tuple of an empty string and “non-null” type for the variable from the context is returned.+checkVarE :: VarEnv -> Var -> (String, Maybe T)+checkVarE varEnv v = case M.lookup v (varMap varEnv) of+ Nothing -> ("Variable " ++ show v ++ " not in environment\n", Nothing)+ vt -> ("", vt)++-- Looks up the operator or value-constructor in the context. If it cannot be found in the context,+-- then a tuple is returned of a non-empty error string warning of this problem and a “null” type.+-- Otherwise, a tuple of an error string and Maybe type is returned from calls to checkVarConsInEnv and checkFuncInEnv+-- depending on if the Func supplied to this function is an value constructor or operator.+checkFunc :: VarEnv -> Func -> (String, Maybe T)+checkFunc varEnv (Func f args) = let vcEnv = M.lookup f (valConstructors varEnv)+ fEnv = M.lookup f (operators varEnv)+ in if isNothing vcEnv && isNothing fEnv+ then ("Function or Val Constructor " ++ show f ++ " not in environment\n", Nothing)+ else maybe (checkFuncInEnv varEnv (Func f args) (fromJust fEnv)) (checkVarConsInEnv varEnv (Func f args)) vcEnv++-- Operates very similarly to checkVarPred described above.+-- The only differences are that this function operates on operators (so checking of arguments to be expressions is+-- unnecessary due to operator parsing) and returns a tuple of an error string and Maybe type.+-- If the substitution “sigma” is generate, then if it is empty, a tuple of an empty error string and the formal+-- return type of the operator is returned, otherwise (if it is not empty) a tuple of an empty error string and the+-- substituted formal return type of the operator is returned. If checking failed for any of the arguments of the operator,+-- then “sigma” is not generated and a tuple of a non-empty error string and “null” type is returned.+checkFuncInEnv :: VarEnv -> Func -> Env.Operator -> (String, Maybe T)+checkFuncInEnv varEnv (Func f args) (Operator name yls kls tls t) =+ let errAndTypesLs = map (checkExpression varEnv) args+ errls = firsts errAndTypesLs+ err = concat errls+ argTypes = map snd errAndTypesLs+ in if foldl (\b at1 -> b && isJust at1) True argTypes+ then let argTypes2 = map (KT . fromJust) argTypes+ tls2 = map KT tls+ (sigma , substErr) = subst varEnv M.empty argTypes2 tls2+ in if sigma == M.empty+ then (substErr ++ err , Just t) -- err should be empty str+ else (substErr ++ err , Just (applySubst sigma t)) -- err should be empty str+ else (err, Nothing)++-- Operates exactly the same as checkFuncInEnv above it just operates over value constructors instead of operators.+checkVarConsInEnv :: VarEnv -> Func -> ValConstructor -> (String, Maybe T)+checkVarConsInEnv varEnv (Func f args) (ValConstructor name yls kls nls tls t) =+ let errAndTypesLs = map (checkExpression varEnv) args+ errls = map fst errAndTypesLs+ err = concat errls+ argTypes = map snd errAndTypesLs+ in if foldl (\b at1 -> b && isJust at1) True argTypes+ then let argTypes2 = map (KT . fromJust) argTypes+ tls2 = map KT tls+ (sigma , substErr) = subst varEnv M.empty argTypes2 tls2+ in if sigma == M.empty+ then (substErr ++ err, Just t) -- err should be empty str+ else (substErr ++ err, Just (applySubst sigma t)) -- err should be empty str+ else (err, Nothing)++-- Takes a substitution “sigma” and applies it to a type. Types that are single type variables are mapped to their corresponding+-- type which exists in “sigma”. Types that are type constructors are mapped to the same type but with their arguments+-- substituted by “sigma” using applySubstitutionHelper.+applySubst :: M.Map Y Arg -> T -> T+applySubst sigma (TTypeVar vt) =+ case sigma M.! TypeVarY vt of+ AVar v -> error "Type var being mapped to variable in subst sigma, error in the TypeChecker!"+ AT t -> t+applySubst sigma (TConstr (TypeCtorApp t args pos)) =+ let argsSub = map (applySubstHelper sigma) args+ in TConstr (TypeCtorApp t argsSub pos)++-- This is a helper function which applies a substitution “sigma” to an argument of a type constructor.+-- If the argument is a variable, then it is mapped to its corresponding variable which exists in “sigma”.+-- If the argument is a type, then it is mapped to the “sigma” substitution of itself using a recursive call to applySubstitution+applySubstHelper :: M.Map Y Arg -> Arg -> Arg+applySubstHelper sigma (AVar v) = case sigma M.! VarY v of+ res@(AVar v2) -> res+ AT t -> error "Var being mapped to a type in subst sigma, error in the TypeChecker!"+applySubstHelper sigma (AT t) = AT (applySubst sigma t)++-- This function (along with its helper functions) follows a recursive-descent unification algorithm to find a substitution+-- “sigma” for two type lists. It generates an entry in a substitution map “sigma” whenever a list of argument types (from+-- a Substance program) and its corresponding list of formal types (from the context) differ.+-- All entries in “sigma” must be consistent for it to be a valid substitution.+-- substitutionHelper is called on each element of a list of tuples of corresponding argument and formal types to generate+-- entries in a substitution “sigma”.+subst :: VarEnv -> M.Map Y Arg -> [K] -> [K] -> (M.Map Y Arg, String)+subst varEnv sigma argTypes formalTypes = let types = zip argTypes formalTypes+ sigma2 = foldl (substHelper varEnv) sigma types+ in if length argTypes /= length formalTypes+ then (sigma2, "Arguments list lengths are not equal, expected " ++ show (length formalTypes) ++ " arguments but call was with " ++ show (length argTypes) ++ " arguments \n" )+ else if compareTypesList varEnv argTypes formalTypes--argTypes /= formalTypes+ then (sigma2, "Incorrect types of arguments, expected " ++ show formalTypes ++ " , but was " ++ show argTypes ++ " \n")+ else (sigma2,"")++compareTypesList :: VarEnv -> [K] ->[K] -> Bool+compareTypesList varEnv argTypes formalTypes =+ let u = zip argTypes formalTypes+ f = filter (compareTypes varEnv) u+ in length u /= length f++compareTypes :: VarEnv -> (K,K) -> Bool+compareTypes varEnv (k1,k2) = (k1 == k2 || isSubtypeK k1 k2 varEnv) -- TODO: remove the equality here (or derive Eq to not include SourcePos)++-- Ensures an argument type and formal type matches where they should match, otherwise a runtime error is generated.+-- In places where they do not need to match exactly (where type and regular variables exist in the formal type)+-- a substitution entry is generated. substitutionHelper2 helps in generating these entries for type constructor arguments and+-- substitutionInsert does the insertion of the entry into the substitution map “sigma”.+substHelper varEnv sigma (KT (TConstr (TypeCtorApp atc argsAT pos1)), KT (TConstr (TypeCtorApp ftc argsFT pos2)))+ | atc `elem` declaredNames varEnv || ftc `elem` declaredNames varEnv =+ substHelper2 varEnv sigma (AVar (VarConst atc), AVar (VarConst ftc))+ | atc /= ftc && not (isSubtype (TConstr (TypeCtorApp atc argsAT pos1)) (TConstr (TypeCtorApp ftc argsFT pos2)) varEnv) =+ error ("Argument type " ++ show atc ++ " doesn't match expected type " ++ show ftc)+ | otherwise = let args = zip argsAT argsFT+ sigma2 = foldl (substHelper2 varEnv) sigma args+ in sigma2+substHelper varEnv sigma (Ktype aT, KT fT) =+ error ("Argument type " ++ show aT ++ " doesn't match expected type " ++ show fT)+substHelper varEnv sigma (KT (TTypeVar atv), KT (TConstr (TypeCtorApp ftc argsFT pos))) =+ error ("Argument type " ++ show atv ++ " doesn't match expected type " ++ show ftc)+substHelper varEnv sigma (KT aT, Ktype fT) =+ error ("Argument type " ++ show aT ++ " doesn't match expected type " ++ show fT)+++-- This helper function makes sure an argument type’s argument matches a formal type’s argument where they should match,+-- otherwise a runtime error is generated. In places where they do not need to match exactly+-- (where type and regular variables exist in the formal type’s argument), a substitution entry is generated and inserted+-- into the substitution map “sigma” using substitutionInsert. Note that substitutionHelper is called recursively to handle+-- substitutions for an argument type’s argument and corresponding formal type’s argument that are both types themselves.+substHelper2 :: VarEnv -> M.Map Y Arg -> (Arg, Arg) -> M.Map Y Arg+substHelper2 varEnv sigma (AVar av, AVar fv) =+ substInsert sigma (VarY fv) (AVar av)+substHelper2 varEnv sigma (AT at, AT ft) =+ substHelper varEnv sigma (KT at, KT ft)+substHelper2 varEnv sigma (AVar av, AT ft) =+ error ("Argument type's argument " ++ show av ++ " doesn't match expected type's argument " ++ show ft)+substHelper2 varEnv sigma (AT at, AVar fv) =+ error("Argument type's argument " ++ show at ++ " doesn't match expected type's argument " ++ show fv)++-- Handles the consistency of entries in the substitution “sigma”, by ensuring that if an entry being inserted into “sigma”+-- already exists in “sigma” it is the same entry as the one already in “sigma”.+-- If the entry doesn’t already exist in “sigma”, then it can be inserted directly without a check for consistency.+substInsert :: M.Map Y Arg -> Y -> Arg -> M.Map Y Arg+substInsert sigma y arg = case M.lookup y sigma of+ Nothing -> M.insert y arg sigma+ arg' -> if arg /= fromJust arg'+ then error "Substitutions inconsistent - no subst can exist"+ else sigma++--argTypeLookupHelper :: VarEnv -> Y -> Either K String+--argTypeLookupHelper varEnv (TypeVarY t) = case M.lookup t (typeVarMap varEnv) of+-- Nothing -> Right "Argument " ++ (show t) ++ " not in environment\n"+-- tType -> Left tType+--argTypeLookupHelper varEnv (VarY v) = case M.lookup v (varMap varEnv) of+-- Nothing -> Right "Argument " ++ (show v) ++ " not in environment\n"+-- vType -> Left vType++----------------------------------------- Binding & Equality Environment ------------------+-- | Definition of the Substance environment + helper functions.+-- Contains binding information and equality of expressions and predicates+-- In order to calculate all the equalities, we compute the closure of the+-- equalities in Substance + symmetry.+-- The equalities do NOT contain self-equalities, which are manually checked by the Style matcher++data SubEnv = SubEnv { exprEqualities :: [(Expr , Expr)],+ predEqualities :: [(Predicate , Predicate)],+ bindings :: M.Map Var Expr,+ subPreds :: [Predicate]+ }+ deriving (Show, Eq, Typeable)++-- | The top level function for computing the Substance environement+-- Important: this function assumes it runs after the typechecker and that+-- the program is well-formed (as well as the DSLL)+loadSubEnv :: SubProg -> SubEnv+loadSubEnv p = let subEnv1 = foldl loadStatement initE p+ subEnv2 = computeEqualityClosure subEnv1+ in subEnv2+ where initE = SubEnv {exprEqualities = [], predEqualities = [], bindings = M.empty, subPreds = []}++-- | The order in all the lists is reserved+loadStatement :: SubEnv -> SubStmt -> SubEnv+loadStatement e (EqualE expr1 expr2) = e { exprEqualities = (expr1, expr2) : exprEqualities e }+loadStatement e (EqualQ q1 q2) = e { predEqualities = (q1, q2) : predEqualities e }+loadStatement e (Bind v expr) = e { bindings = M.insert v expr $ bindings e }+loadStatement e (ApplyP p) = e { subPreds = p : subPreds e }+loadStatement e _ = e -- for all other statements, simply pass on the environment++computeEqualityClosure:: SubEnv -> SubEnv+computeEqualityClosure e = e { predEqualities = transitiveClosure (predEqualities e),+ exprEqualities = transitiveClosure (exprEqualities e) }++-- | Given an environment and 2 expressions, determine whether those expressions are equal+-- For use in Style+exprsDeclaredEqual :: SubEnv -> Expr -> Expr -> Bool+exprsDeclaredEqual env e1 e2 = (e1, e2) `elem` exprEqualities env || (e2, e1) `elem` exprEqualities env++-- | Given an environment and 2 predicates determine whether those predicates are equal+-- For use in Style+predsDeclaredEqual :: SubEnv -> Predicate -> Predicate -> Bool+predsDeclaredEqual env q1 q2 = (q1, q2) `elem` predEqualities env || (q2, q1) `elem` predEqualities env++-- --------------------------------------- Substance Loader --------------------------------+-- | Load all the Substance objects for visualization in Runtime.hs++-- | Mapping from Subtance IDs to (maybe) label texts. A Substance object+-- might not have labels due to the lack of @Label@ or existance of+-- @NoLabel@+type LabelMap = M.Map String (Maybe String)++-- TODO: better name for the type+data SubObjects = SubObjects {+ -- | declared Substance objects (including constraints, which is, again, viewed also as objects)+ subObjs :: [SubObj],+ -- | a map that stores all label texts associated with each Substance+ -- object (TODO: are predicates included? currently not.)+ subLabels :: LabelMap+} deriving (Show, Eq, Typeable)++-- | generate a mapping from substance IDs to their label strings+getLabelMap :: SubProg -> VarEnv -> LabelMap+getLabelMap p env = collectLabels subIds p+ where+ subIds = map (\(VarConst v) -> v) $ M.keys (varMap env)++-- | Given all label statements and Substance IDs, generate a map from+-- all ids to their labels+collectLabels :: [String] -> SubProg -> LabelMap+collectLabels ids =+ foldl (\m stmt -> case stmt of+ LabelDecl (VarConst i) s -> M.insert i (Just s) m+ AutoLabel Default ->+ M.fromList $ zip ids $ map Just ids+ AutoLabel (IDs ids) ->+ foldl (\m' (VarConst i) -> M.insert i (Just i) m') m ids+ NoLabel ids ->+ foldl (\m' (VarConst i) -> M.insert i Nothing m') m ids+ _ -> m+ ) initmap+ where+ initmap = M.fromList $ map (\i -> (i, Nothing)) ids++-- COMBAK: DEPRECATED+loadObjects :: SubProg -> VarEnv -> SubObjects+loadObjects p env =+ let objs1 = foldl (passDecls env) initObjs p+ objs2 = foldl passReferencess objs1 p+ labels = collectLabels subIds $ filter labelStmt p+ in objs2 {+ subObjs = reverse $ subObjs objs2,+ subLabels = labels+ }+ where+ initObjs = SubObjects { subObjs = [], subLabels = M.empty }+ subIds = map (\(VarConst v) -> v) $ M.keys (varMap env)+ labelStmt s = case s of+ LabelDecl _ _ -> True+ AutoLabel _ -> True+ NoLabel _ -> True+ _ -> False++applyDef :: Ord k => (k, v) -> M.Map k (a, b) -> b+applyDef (n, _) d = case M.lookup n d of+ Nothing -> error "applyDef: definition not found!"+ Just (_, e) -> e++-- | 'passDecls' checks the validity of declarations of objects.+passDecls :: VarEnv -> SubObjects -> SubStmt -> SubObjects+passDecls subEnv e (Decl t s) = e { subObjs = toObj subEnv t s : subObjs e }+passDecls subEnv e _ = e -- Ignore all other statements++-- | 'toObj' translates [Type] + [Identiers] to concrete Substance objects, to be selected by the Style program+toObj :: VarEnv -> T -> Var -> SubObj+toObj e t v = LD $ SubDeclConst (fixAST e t) v++fixAST :: VarEnv -> T -> T+fixAST e (TConstr c) = TConstr (c { argCons = map (fixArg e) $ argCons c })+fixAST e t = t -- Ignore all other cases++fixArg :: VarEnv -> Arg -> Arg+fixArg e (AT (TConstr i)) = if nameCons i `elem` declaredNames e+ then AVar (VarConst (nameCons i))+ else AT (TConstr i)+fixArg e a = a -- Ignore all other cases++-- | 'passReferencess' checks any statement that refers to other objects. For example,+-- | > Subset A B+-- | refers to identifiers @A@ and @B@. The function will perform a lookup in the symbol table, make sure the objects exist and are of desired types -- in this case, 'Set' -- and throws an error otherwise.+passReferencess :: SubObjects -> SubStmt -> SubObjects+passReferencess e (ApplyP (Predicate (PredicateConst t) args pos)) =+ e { subObjs = toConstr t args : subObjs e }+passReferencess e _ = e -- Ignore all other statements++-- | Similar to 'toObj'+toConstr :: String -> [PredArg] -> SubObj+toConstr p vl = LC $ SubConstrConst p vl++-- | `subSeparate` splits a list of Substance objects into declared objects and constaints on these objects+subSeparate :: [SubObj] -> SubObjDiv+subSeparate = foldr separate ([], [])+ where separate line (decls, constrs) =+ case line of+ (LD x) -> (x : decls, constrs)+ (LC x) -> (decls, x : constrs)+++-- | 'parseSubstance' runs the actual parser function: 'substanceParser', taking in a program String, parses it, semantically checks it, and eventually invoke Alloy if needed. It outputs a collection of Substance objects at the end.+parseSubstance :: String -> String -> VarEnv -> Either CompilerError SubOut +parseSubstance subFile subIn varEnv =+ case runParser (substanceParser varEnv) subFile subIn of+ Left err -> Left $ SubstanceParse (errorBundlePretty err)+ Right subProg -> do+ let subProg' = refineAST subProg varEnv+ let subTypeEnv = check subProg' varEnv+ let subDynEnv = loadSubEnv subProg'+ let labelMap = getLabelMap subProg' subTypeEnv+ Right $ (SubOut subProg' (subTypeEnv, subDynEnv) labelMap)++--------------------------------------------------------------------------------+-- COMBAK: organize this section and maybe rewrite some of the functions+-- Will be deprecated once Style is rewritten++-- | Generate a unique id for a Substance constraint+-- FIXME: make sure these names are unique and make sure users cannot start ids+-- with underscores++varListToString :: [Var] -> [String]+varListToString = map conv+ where conv (VarConst s) = s++--TODO: Support all the other cases+convPredArg :: PredArg -> String+convPredArg (PE (VarE (VarConst s))) = s+convPredArg c = show c++predArgListToString :: [PredArg] -> [String]+predArgListToString = map convPredArg++varArgsToString :: [Arg] -> [String]+varArgsToString = map conv+ where conv c = case c of+ AVar (VarConst s) -> s+ _ -> ""+exprToString :: [Expr] -> [String]+exprToString = map show++-- HACK: predicates are anonymous. There shouldn't be any id attached to it. Going to change in Style compiler rewrite+getConstrTuples :: [SubConstr] -> [(TypeName, String, [String])]+getConstrTuples = map getType+ where getType (SubConstrConst p vs) = (TypeNameConst p, "_" ++ p ++ intercalate "" (predArgListToString vs), predArgListToString vs)++getSubTuples :: [SubDecl] -> [(TypeName, String, [String])]+getSubTuples = map getType+ where getType d = case d of+ SubDeclConst (TConstr (TypeCtorApp t xls pos1)) (VarConst v) -> (TypeNameConst t, v, v : varArgsToString xls)+ SubDeclConst (TTypeVar (TypeVar name pos2)) (VarConst v) -> (TypeNameConst name, v, [v])++getAllIds :: ([SubDecl], [SubConstr]) -> [String]+getAllIds (decls, constrs) = map (\(_, x, _) -> x) $ getSubTuples decls ++ getConstrTuples constrs+++-- --------------------------------------- Test Driver -------------------------+-- | For testing: first uncomment the module definition to make this module the+-- Main module. Usage: ghc SubstanceCore.hs; ./SubstanceCore <substance core-file>++main :: IO ()+main = do+ args <- getArgs+ let subFile = head args+ subIn <- readFile subFile+ -- parseTest substanceParser subIn+ --parsed <- parseFromFile+ --mapM_ print parsed+ return ()
+ src/SubstanceJSON.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_HADDOCK prune #-}++module SubstanceJSON where++import Data.Aeson+import qualified Data.ByteString.Lazy as BL+import qualified Data.List as L+import Debug.Trace+import GHC.Generics++import qualified Env as E+import Substance++-------------------------------------------------------+-- | JSON schemas and derivations using Aeson+data FunctionSchema = FunctionSchema+ { varName :: String+ , fname :: String+ , fargNames :: [String]+ } deriving (Generic, Show)++data PredicateSchema = PredicateSchema+ { pname :: String+ , pargNames :: [String]+ } deriving (Generic, Show)++data ConstraintSchema = ConstraintSchema+ { functions :: [FunctionSchema]+ , predicates :: [PredicateSchema]+ } deriving (Generic, Show)++data ObjectSchema = ObjectSchema+ { objType :: String+ , objName :: String+ } deriving (Generic, Show)++data SubSchema = SubSchema+ { objects :: [ObjectSchema]+ , constraints :: ConstraintSchema+ } deriving (Generic, Show)++instance ToJSON ObjectSchema where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON ObjectSchema++instance ToJSON PredicateSchema where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON PredicateSchema++instance ToJSON FunctionSchema where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON FunctionSchema++instance ToJSON ConstraintSchema where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON ConstraintSchema++instance ToJSON SubSchema where+ toEncoding = genericToEncoding defaultOptions++instance FromJSON SubSchema++-------------------------------------------------------+targToSchema :: E.Arg -> String+targToSchema (E.AVar (E.VarConst s)) = s+targToSchema (E.AT t) = tToSchema t++tToSchema :: E.T -> String+tToSchema (E.TTypeVar typeVar) = E.typeVarName typeVar+tToSchema (E.TConstr typeCtorApp) =+ let ctorString = E.nameCons typeCtorApp+ args = E.argCons typeCtorApp+ in case args of+ [] -> ctorString -- "Set"+ _ ->+ ctorString +++ "(" ++ (L.intercalate ", " $ map targToSchema args) ++ ")" -- "List(Bounce)"++exprToSchema :: Expr -> String+exprToSchema (VarE (E.VarConst v)) = v+exprToSchema _ =+ error+ "Cannot convert anonymous expressions in function/val ctor arguments to JSON; must name them first"++prednameToSchema :: PredicateName -> String+prednameToSchema (PredicateConst s) = s++predargToSchema :: PredArg -> String+predargToSchema (PE expr) = exprToSchema expr+predargToSchema (PP pred) =+ error "Cannot convert nested predicate in predicate argument to JSON"++-- | Convert a Substance statement to a JSON format and adds it to the right list+-- | Note: do not rely on ordering in JSON, as this function does not guarantee preserving Substance program order.+-- | However, we do guarantee preserving argument order in function/valcons/predicate applications.+toSchema ::+ ([ObjectSchema], [FunctionSchema], [PredicateSchema])+ -> SubStmt+ -> ([ObjectSchema], [FunctionSchema], [PredicateSchema])+toSchema acc@(objSchs, fnSchs, predSchs) subLine =+ case subLine of+ Decl t (E.VarConst v) ->+ let res = ObjectSchema {objType = tToSchema t, objName = v}+ in (res : objSchs, fnSchs, predSchs)+ DeclList t vs ->+ let decls = map (\v -> Decl t v) vs+ in foldl toSchema acc decls+ Bind (E.VarConst v) (ApplyFunc f) ->+ let res =+ FunctionSchema+ { varName = v+ , fname = nameFunc f+ , fargNames = map exprToSchema $ argFunc f+ }+ in (objSchs, res : fnSchs, predSchs)+ Bind (E.VarConst v) (ApplyValCons f) ->+ let res =+ FunctionSchema+ { varName = v+ , fname = nameFunc f+ , fargNames = map exprToSchema $ argFunc f+ }+ in (objSchs, res : fnSchs, predSchs)+ ApplyP p ->+ let res =+ PredicateSchema+ { pname = prednameToSchema $ predicateName p+ , pargNames = map predargToSchema $ predicateArgs p+ }+ in (objSchs, fnSchs, res : predSchs)+ -- TODO: these forms are not sent to plugins+ Bind _ (VarE _) ->+ trace "WARNING: not sending Substance form to plugin!" acc+ Bind _ (DeconstructorE _) ->+ trace "WARNING: not sending Substance form to plugin!" acc+ EqualE _ _ -> trace "WARNING: not sending Substance form to plugin!" acc+ EqualQ _ _ -> trace "WARNING: not sending Substance form to plugin!" acc+ LabelDecl _ _ -> acc+ AutoLabel _ -> acc+ NoLabel _ -> acc++-- | Turn a Substance prog into the schema format defined above+subToSchema :: SubProg -> SubSchema+subToSchema prog =+ let (objSchs, fnSchs, predSchs) = foldl toSchema ([], [], []) prog+ in SubSchema+ { objects = objSchs+ , constraints =+ ConstraintSchema {functions = fnSchs, predicates = predSchs}+ }++-- | This is the main function for converting a parsed Substance program to JSON format, called in ShadowMain+writeSubstanceToJSON :: FilePath -> SubOut -> IO ()+writeSubstanceToJSON file (SubOut subprog envs labels) = do+ let substanceSchema = subToSchema subprog+ let bytestr = encode substanceSchema+ BL.writeFile file bytestr++--------------------------------------------------------+-- | JSON format for parsing Style values from plugins+data KeyValPair = KeyValPair+ { propertyName :: String+ , propertyVal :: Float -- TODO: generalize this+ } deriving (Generic, Show)++data StyVal = StyVal+ { subName :: String+ , nameVals :: [KeyValPair]+ } deriving (Generic, Show)++instance FromJSON KeyValPair++instance FromJSON StyVal++-- Plugin output parsed as [StyVal]+--------------------------------------------------------+-- | Test writing a Substance program in JSON format+main :: IO ()+main+ -- let subProg = "Set A\nSet B\n IsSubset(A,B)\nSet C\nC := Union(A, B)\n\nPoint p\n PointIn(C, p)\nC := AddPoint(p, C)\n\nAutoLabel All"+ = do+ let testFile = "testSubstanceJSON.json"+ let info =+ SubSchema+ { objects = [ObjectSchema {objType = "Set", objName = "A"}]+ , constraints =+ ConstraintSchema+ { functions =+ [ FunctionSchema+ {varName = "C", fname = "Union", fargNames = ["A", "B"]}+ ]+ , predicates =+ [PredicateSchema {pname = "IsSubset", pargNames = ["C", "p"]}]+ }+ }+ let res = encode info+ BL.writeFile testFile res
+ src/SubstanceTokenizer.hs view
@@ -0,0 +1,994 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP,MagicHash #-}+{-# LINE 1 "src/SubstanceTokenizer.x" #-}++module SubstanceTokenizer where++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Array.Base (unsafeAt)+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+{-# LINE 1 "templates/wrappers.hs" #-}+-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.+++++++import Data.Word (Word8)+++++++++++++++++import Data.Char (ord)+import qualified Data.Bits++-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+utf8Encode :: Char -> [Word8]+utf8Encode = map fromIntegral . go . ord+ where+ go oc+ | oc <= 0x7f = [oc]++ | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)+ , 0x80 + oc Data.Bits..&. 0x3f+ ]++ | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)+ , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+ , 0x80 + oc Data.Bits..&. 0x3f+ ]+ | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)+ , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)+ , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+ , 0x80 + oc Data.Bits..&. 0x3f+ ]++++type Byte = Word8++-- -----------------------------------------------------------------------------+-- The input type+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text. It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.+++++++++++++++-- -----------------------------------------------------------------------------+-- Default monad+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- -----------------------------------------------------------------------------+-- Monad (with ByteString input)++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- -----------------------------------------------------------------------------+-- Basic wrapper+++type AlexInput = (Char,[Byte],String)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (c,_,_) = c++-- alexScanTokens :: String -> [token]+alexScanTokens str = go ('\n',[],str)+ where go inp__@(_,_bs,s) =+ case alexScan inp__ 0 of+ AlexEOF -> []+ AlexError _ -> error "lexical error"+ AlexSkip inp__' _ln -> go inp__'+ AlexToken inp__' len act -> act (take len s) : go inp__'++alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)+alexGetByte (c,(b:bs),s) = Just (b,(c,bs,s))+alexGetByte (_,[],[]) = Nothing+alexGetByte (_,[],(c:s)) = case utf8Encode c of+ (b:bs) -> Just (b, (c, bs, s))+ [] -> Nothing++++-- -----------------------------------------------------------------------------+-- Basic wrapper, ByteString version+++++++++++++++++++++++++++++++++-- -----------------------------------------------------------------------------+-- Posn wrapper++-- Adds text positions to the basic model.++++++++++++++-- -----------------------------------------------------------------------------+-- Posn wrapper, ByteString version+++++++++++++++-- -----------------------------------------------------------------------------+-- GScan wrapper++-- For compatibility with previous versions of Alex, and because we can.+++++++++++++++alex_tab_size :: Int+alex_tab_size = 8+alex_base :: AlexAddr+alex_base = AlexA#+ "\xf8\xff\xff\xff\xa9\xff\xff\xff\xdb\xff\xff\xff\x60\xff\xff\xff\x55\xff\xff\xff\x6f\xff\xff\xff\x74\xff\xff\xff\x5b\x00\x00\x00\xdb\x00\x00\x00\x5b\x01\x00\x00\xdb\x01\x00\x00\x5b\x02\x00\x00\xdb\x02\x00\x00\x5b\x03\x00\x00\xdb\x03\x00\x00\x5b\x04\x00\x00\xdb\x04\x00\x00\x00\x00\x00\x00\x4c\x05\x00\x00\x00\x00\x00\x00\xbd\x05\x00\x00\x00\x00\x00\x00\x2e\x06\x00\x00\x00\x00\x00\x00\x9f\x06\x00\x00\x00\x00\x00\x00\x10\x07\x00\x00\x8e\xff\xff\xff\x8f\xff\xff\xff\x8a\xff\xff\xff\xe5\xff\xff\xff\x00\x00\x00\x00\xb8\xff\xff\xff\x00\x00\x00\x00\x51\x07\x00\x00\x00\x00\x00\x00\x92\x07\x00\x00\x00\x00\x00\x00\xd3\x07\x00\x00\x00\x00\x00\x00\x14\x08\x00\x00\x2b\x00\x00\x00\x8c\x08\x00\x00\x90\xff\xff\xff\xd7\xff\xff\xff\xe9\xff\xff\xff\x38\x09\x00\x00\xf8\x08\x00\x00\x00\x00\x00\x00\xf8\x09\x00\x00\xb8\x09\x00\x00\x00\x00\x00\x00\xb8\x0a\x00\x00\x78\x0a\x00\x00\x00\x00\x00\x00\x78\x0b\x00\x00\x38\x0b\x00\x00\x00\x00\x00\x00\x38\x0c\x00\x00\xf8\x0b\x00\x00\x00\x00\x00\x00\xee\x0c\x00\x00\xe4\x0d\x00\x00\xda\x0e\x00\x00\xd0\x0f\x00\x00\xc6\x10\x00\x00\x0c\x09\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\xf1\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xff\xff\xfc\xff\xff\xff\xed\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x01\x00\x00\x00\x03\x00\x00\x00\x98\x11\x00\x00\xe5\x11\x00\x00\x3a\x12\x00\x00\x87\x12\x00\x00\xdc\x12\x00\x00\x29\x13\x00\x00\x7e\x13\x00\x00\xcb\x13\x00\x00\x20\x14\x00\x00\x6d\x14\x00\x00\xc2\x14\x00\x00\x0f\x15\x00\x00\x64\x15\x00\x00\xb1\x15\x00\x00\x06\x16\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA#+ "\x00\x00\x42\x00\x43\x00\x42\x00\x42\x00\x42\x00\x4d\x00\x53\x00\x5c\x00\x1e\x00\x53\x00\x53\x00\x53\x00\x64\x00\x06\x00\x05\x00\x29\x00\x53\x00\x2a\x00\x01\x00\x2b\x00\x47\x00\x53\x00\x45\x00\x42\x00\x53\x00\x43\x00\x53\x00\x53\x00\x53\x00\x53\x00\x46\x00\x4a\x00\x4b\x00\x50\x00\x53\x00\x4c\x00\x4f\x00\x2d\x00\x55\x00\x3f\x00\x04\x00\x49\x00\x41\x00\x2c\x00\x40\x00\x00\x00\x02\x00\x00\x00\x00\x00\x51\x00\x44\x00\x52\x00\x48\x00\x53\x00\x53\x00\x4e\x00\x5b\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x58\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x54\x00\x00\x00\x53\x00\x53\x00\x00\x00\x53\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x53\x00\x00\x00\x53\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x03\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x1d\x00\x3a\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x37\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x34\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x31\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x2e\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x07\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x08\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x09\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x0a\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x0b\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x28\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x35\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x42\x00\x00\x00\x42\x00\x42\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3c\x00\x3b\x00\x07\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x28\x00\x0c\x00\x19\x00\x19\x00\x19\x00\x1a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x39\x00\x38\x00\x08\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x26\x00\x0d\x00\x17\x00\x17\x00\x17\x00\x18\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x36\x00\x35\x00\x09\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x24\x00\x0e\x00\x15\x00\x15\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x33\x00\x32\x00\x0a\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x22\x00\x0f\x00\x13\x00\x13\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x30\x00\x2f\x00\x0b\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x1f\x00\x20\x00\x10\x00\x11\x00\x11\x00\x11\x00\x12\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x63\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x62\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x64\x00\x61\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x60\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5f\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x64\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5e\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x64\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5a\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x59\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x57\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x56\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x3e\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x3d\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+ "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x5d\x00\xa7\x00\x99\x00\x2e\x00\xb5\x00\xb6\x00\xb7\x00\x99\x00\x80\x00\x80\x00\x86\x00\xb1\x00\x88\x00\x2e\x00\x8a\x00\x3e\x00\x86\x00\x2e\x00\x20\x00\x21\x00\x0a\x00\x23\x00\x24\x00\x25\x00\x26\x00\x2e\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x2d\x00\x9f\x00\x3d\x00\x2f\x00\x2d\x00\x2a\x00\xff\xff\x2e\x00\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x5d\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xc2\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xae\x00\xe2\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x88\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xaa\x00\xab\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+ "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1f\x00\x1f\x00\x21\x00\x21\x00\x23\x00\x23\x00\x25\x00\x25\x00\x27\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x30\x00\x33\x00\x33\x00\x36\x00\x36\x00\x39\x00\x39\x00\x3c\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x41\x00\x41\x00\x40\x00\x40\x00\x40\x00\x3f\x00\x3f\x00\x3f\x00\x3e\x00\x3e\x00\x3e\x00\x3d\x00\x3d\x00\x3d\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0 :: Int, 100)+ [ AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAcc 39+ , AlexAcc 38+ , AlexAcc 37+ , AlexAcc 36+ , AlexAcc 35+ , AlexAcc 34+ , AlexAcc 33+ , AlexAcc 32+ , AlexAcc 31+ , AlexAcc 30+ , AlexAcc 29+ , AlexAcc 28+ , AlexAcc 27+ , AlexAcc 26+ , AlexAcc 25+ , AlexAcc 24+ , AlexAcc 23+ , AlexAcc 22+ , AlexAcc 21+ , AlexAcc 20+ , AlexAcc 19+ , AlexAcc 18+ , AlexAcc 17+ , AlexAcc 16+ , AlexAcc 15+ , AlexAcc 14+ , AlexAcc 13+ , AlexAcc 12+ , AlexAcc 11+ , AlexAcc 10+ , AlexAcc 9+ , AlexAcc 8+ , AlexAcc 7+ , AlexAcc 6+ , AlexAcc 5+ , AlexAcc 4+ , AlexAcc 3+ , AlexAcc 2+ , AlexAcc 1+ , AlexAcc 0+ ]++alex_actions = array (0 :: Int, 40)+ [ (39,alex_action_0)+ , (38,alex_action_1)+ , (37,alex_action_2)+ , (36,alex_action_3)+ , (35,alex_action_4)+ , (34,alex_action_5)+ , (33,alex_action_6)+ , (32,alex_action_7)+ , (31,alex_action_8)+ , (30,alex_action_9)+ , (29,alex_action_10)+ , (28,alex_action_11)+ , (27,alex_action_12)+ , (26,alex_action_13)+ , (25,alex_action_14)+ , (24,alex_action_15)+ , (23,alex_action_16)+ , (22,alex_action_17)+ , (21,alex_action_18)+ , (20,alex_action_18)+ , (19,alex_action_18)+ , (18,alex_action_18)+ , (17,alex_action_18)+ , (16,alex_action_18)+ , (15,alex_action_18)+ , (14,alex_action_19)+ , (13,alex_action_19)+ , (12,alex_action_19)+ , (11,alex_action_19)+ , (10,alex_action_19)+ , (9,alex_action_19)+ , (8,alex_action_19)+ , (7,alex_action_19)+ , (6,alex_action_19)+ , (5,alex_action_19)+ , (4,alex_action_19)+ , (3,alex_action_19)+ , (2,alex_action_19)+ , (1,alex_action_19)+ , (0,alex_action_20)+ ]++{-# LINE 33 "src/SubstanceTokenizer.x" #-}++-- Each action has type :: String -> Token+-- The token type:+data Token =+ Bind |+ Iterator |+ Iter |+ NewLine |+ PredEq |+ ExprEq |+ Comma |+ Lparen |+ Rparen |+ Space |+ Sym Char |+ Var String |+ RecursivePattern [Token] |+ RecursivePatternElement [Token] |+ SinglePatternElement [Token] |+ Pattern String Bool |+ Entitiy String |+ DSLLEntity String |+ Label String |+ AutoLabel String |+ Comment String |+ StartMultiComment String |+ EndMultiComment String+ deriving (Show)++instance Eq Token where+ Bind == Bind = True+ NewLine == NewLine = True+ PredEq == PredEq = True+ ExprEq == ExprEq = True+ Comma == Comma = True+ Lparen == Lparen = True+ Rparen == Rparen = True+ Space == Space = True+ Sym c1 == Sym c2 = c1 == c2+ Var c1 == Var c2 = c1 == c2+ Pattern c1 b1 == Pattern c2 b2 = True+ Entitiy c1 == Entitiy c2 = c1 == c2+ DSLLEntity c1 == DSLLEntity c2 = c1 == c2+ Comment c1 == Comment c2 = c1 == c2+ StartMultiComment c1 == StartMultiComment c2 = c1 == c2+ EndMultiComment c1 == EndMultiComment c2 = c1 == c2+ RecursivePatternElement lst1 == RecursivePatternElement lst2 = True+ RecursivePattern lst1 == RecursivePattern lst2 = lst1 == lst2+ a == b = False+++main = do+ s <- getContents+ print (alexScanTokens s)++alex_action_0 = \s -> Label s +alex_action_1 = \s -> AutoLabel s +alex_action_2 = \s -> Comment s +alex_action_3 = \s -> StartMultiComment s+alex_action_4 = \s -> EndMultiComment s+alex_action_5 = \s -> Space+alex_action_6 = \s -> NewLine+alex_action_7 = \s -> NewLine+alex_action_8 = \s -> RecursivePatternElement []+alex_action_9 = \s -> RecursivePattern []+alex_action_10 = \s -> PredEq +alex_action_11 = \s -> ExprEq +alex_action_12 = \s -> Bind +alex_action_13 = \s -> Lparen +alex_action_14 = \s -> Rparen +alex_action_15 = \s -> Comma +alex_action_16 = \s -> Iterator +alex_action_17 = \s -> Iter +alex_action_18 = \s -> Sym (head s) +alex_action_19 = \s -> Var s +alex_action_20 = \s -> Pattern s False +{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++++++++++++++++++-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ > 706+#define GTE(n,m) (tagToEnum# (n >=# m))+#define EQ(n,m) (tagToEnum# (n ==# m))+#else+#define GTE(n,m) (n >=# m)+#define EQ(n,m) (n ==# m)+#endif++++++++++++++++++++data AlexAddr = AlexA# Addr#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+ indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 4#+#else+ indexInt32OffAddr# arr off+#endif+++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input__ (I# (sc))+ = alexScanUser undefined input__ (I# (sc))++alexScanUser user__ input__ (I# (sc))+ = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of+ (AlexNone, input__') ->+ case alexGetByte input__ of+ Nothing ->++++ AlexEOF+ Just _ ->++++ AlexError input__'++ (AlexLastSkip input__'' len, _) ->++++ AlexSkip input__'' len++ (AlexLastAcc k input__''' len, _) ->++++ AlexToken input__''' len (alex_actions ! k)+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user__ orig_input len input__ s last_acc =+ input__ `seq` -- strict in the input+ let+ new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))+ in+ new_acc `seq`+ case alexGetByte input__ of+ Nothing -> (new_acc, input__)+ Just (c, new_input) ->++++ case fromIntegral c of { (I# (ord_c)) ->+ let+ base = alexIndexInt32OffAddr alex_base s+ offset = (base +# ord_c)+ check = alexIndexInt16OffAddr alex_check offset++ new_s = if GTE(offset,0#) && EQ(check,ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of+ -1# -> (new_acc, input__)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)+ -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+ new_input new_s new_acc+ }+ where+ check_accs (AlexAccNone) = last_acc+ check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len))+ check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len))++++++++++++++data AlexLastAcc+ = AlexNone+ | AlexLastAcc !Int !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc user+ = AlexAccNone+ | AlexAcc Int+ | AlexAccSkip+++++++++++++++++++++++++++++
+ src/SubstanceTokenizer.x view
@@ -0,0 +1,87 @@+{+module SubstanceTokenizer where+}+%wrapper "basic"+$digit = 0-9+$alpha = [a-zA-Z]+$symbol = [\=\+\-\*\/\:\∈\←\→\↑\↓\↔\↕\↖\↗\↘\↙\↚\↛\↮\⟵\⟶\⟷\<\>\|\;\~\`\!\#\%\&\*\±\§\?\$\<\>\⊆\∪\∩\`\∫\[\]\^]+tokens :-+ -- digits+ -- alphabetic characters+ "Label".* { \s -> Label s }+ "AutoLabel".* { \s -> AutoLabel s }+ "--".* { \s -> Comment s }+ "/*".* { \s -> StartMultiComment s}+ "*/".* { \s -> EndMultiComment s}+ [\ \t\f\v\r]+ {\s -> Space}+ [\n]+ {\s -> NewLine}+ \; {\s -> NewLine}+ [\.]{2} {\s -> RecursivePatternElement []}+ [\.]{3} {\s -> RecursivePattern []}+ \<\-\> { \s -> PredEq }+ \= { \s -> ExprEq }+ \:= { \s -> Bind }+ \( { \s -> Lparen }+ \) { \s -> Rparen }+ \, { \s -> Comma }+ \[\.\.\.\] { \s -> Iterator }+ \[\.\] { \s -> Iter }+ $symbol { \s -> Sym (head s) }+ $alpha [$alpha $digit \_ \’ \.]* { \s -> Var s }+ $alpha \`[$alpha $digit \_ \’]* { \s -> Pattern s False }++{+-- Each action has type :: String -> Token+-- The token type:+data Token =+ Bind |+ Iterator |+ Iter |+ NewLine |+ PredEq |+ ExprEq |+ Comma |+ Lparen |+ Rparen |+ Space |+ Sym Char |+ Var String |+ RecursivePattern [Token] |+ RecursivePatternElement [Token] |+ SinglePatternElement [Token] |+ Pattern String Bool |+ Entitiy String |+ DSLLEntity String |+ Label String |+ AutoLabel String |+ Comment String |+ StartMultiComment String |+ EndMultiComment String+ deriving (Show)++instance Eq Token where+ Bind == Bind = True+ NewLine == NewLine = True+ PredEq == PredEq = True+ ExprEq == ExprEq = True+ Comma == Comma = True+ Lparen == Lparen = True+ Rparen == Rparen = True+ Space == Space = True+ Sym c1 == Sym c2 = c1 == c2+ Var c1 == Var c2 = c1 == c2+ Pattern c1 b1 == Pattern c2 b2 = True+ Entitiy c1 == Entitiy c2 = c1 == c2+ DSLLEntity c1 == DSLLEntity c2 = c1 == c2+ Comment c1 == Comment c2 = c1 == c2+ StartMultiComment c1 == StartMultiComment c2 = c1 == c2+ EndMultiComment c1 == EndMultiComment c2 = c1 == c2+ RecursivePatternElement lst1 == RecursivePatternElement lst2 = True+ RecursivePattern lst1 == RecursivePattern lst2 = lst1 == lst2+ a == b = False+++main = do+ s <- getContents+ print (alexScanTokens s)+}
+ src/Sugarer.hs view
@@ -0,0 +1,173 @@+-- This module get as an input a Substance program (a text) and preform a+-- textual replacement of all the statement notation specified in the Element+-- environment / the Element AST, the result is a semi-sugared Substance program+-- which will be passed to the Substance parser+{-# OPTIONS_HADDOCK prune #-}++module Sugarer where++--module Main (main) where -- for debugging purposes+import Control.Arrow ((>>>))+import Control.Monad (void)+import Control.Monad.Combinators.Expr+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Typeable+import Data.Void+import Debug.Trace+import Env+import System.Environment+import System.IO+import System.Process+import Text.Megaparsec+import Text.Megaparsec.Char+import Utils++import qualified Data.Map.Strict as M+import qualified Element as D+import qualified SubstanceTokenizer as T+import qualified Text.Megaparsec.Char.Lexer as L+import qualified Tokenizer++-------------------------------- Sugaring --------------------------------------+-- | The top-level function for translating StmtNotations, gets as an input String of+-- sugared program + the Element env, and returns a string of desugared program.+-- All the NotationStmts are stored in elementEnv.+sugarStmts :: String -> VarEnv -> String+sugarStmts prog elementEnv =+ let notations = stmtNotations elementEnv+ tokenizedProg = Tokenizer.tokenizeSugaredSubstance prog elementEnv+ str =+ foldl+ (sugarStmt elementEnv)+ (filter Tokenizer.spaces tokenizedProg)+ notations+ in Tokenizer.reTokenize str++-- | Preform a replacement of a specific given StmtNotationRule over+-- a list of tokens.+sugarStmt :: VarEnv -> [T.Token] -> StmtNotationRule -> [T.Token]+sugarStmt elementEnv tokens rule =+ let from = fromSnr rule+ to = toSnr rule+ patterns = patternsSnr rule+ in if isRecursivePattern to+ then handleRecursivePattern from to patterns tokens+ else handleNonRecursivePattern from to patterns tokens++-- | Handle a specific recursive pattern, as part of handling recursive patterns+-- we need to refine the sugared substance tokens list to recognize recursive+-- patterns before the actual split+handleRecursivePattern from to patterns tokens =+ let c = groupBy cmpSubst tokens+ c' = concat (foldl replaceToRecursivePattern [] c)+ c'' = split (onSublist (filter Tokenizer.spaces to)) c'+ splittedReplaced = concat (foldl (replace from to patterns) [] c'')+ recursivePattern = foldl findRecursivePattern [] splittedReplaced+ final =+ foldl+ (replaceToRecursivePatternElement recursivePattern)+ []+ splittedReplaced+ in (traceShowId final)++replaceToRecursivePatternElement recursivePattern lst (T.RecursivePatternElement p) =+ lst ++ p+replaceToRecursivePatternElement recursivePattern lst t = lst ++ [t]++findRecursivePattern lst (T.RecursivePattern p) = lst ++ p+findRecursivePattern lst _ = lst++cmpSubst :: T.Token -> T.Token -> Bool+cmpSubst (T.Pattern _ _) T.Comma = True+cmpSubst a b = a == b++replaceToRecursivePattern :: [[T.Token]] -> [T.Token] -> [[T.Token]]+replaceToRecursivePattern lst subSeq =+ if length subSeq > 1 &&+ (head $ tail subSeq) == T.Comma && head subSeq == T.Pattern "" False+ then lst ++ [[T.RecursivePattern subSeq]]+ else lst ++ [subSeq]++-- | Handle non recursive patterns+handleNonRecursivePattern from to patterns tokens =+ let splitted = split (onSublist (filter Tokenizer.spaces to)) tokens+ splittedReplaced = foldl (replace from to patterns) [] splitted+ in concat splittedReplaced++isRecursivePattern :: [T.Token] -> Bool+isRecursivePattern tokens = T.RecursivePattern [] `elem` tokens++-- Preform the actual replacement of a pattern+replace ::+ [T.Token]+ -> [T.Token]+ -> [T.Token]+ -> [[T.Token]]+ -> [T.Token]+ -> [[T.Token]]+replace from to patterns lst chunk =+ if comparePattern to chunk patterns+ then let patternMatch =+ zip+ (filter Tokenizer.notAllPatterns to)+ (filter Tokenizer.notAllPatterns chunk)+ from' =+ foldl+ updateValue+ from+ (patternMatch +++ [(T.RecursivePatternElement [], T.RecursivePatternElement [])])+ in lst ++ [from']+ else lst ++ [chunk]++-- | Replace elements in the token list according to the pattern match, make+-- sure that each element is replaced at most one time, in order to avoid+-- collisions+replaceElement (T.Pattern p1 b1) (T.Pattern p2 b2) (T.Pattern x b3) =+ if p1 == x && not b3+ then T.Pattern p2 True+ else T.Pattern x b3+replaceElement (T.RecursivePattern p1) (T.RecursivePattern p2) (T.RecursivePattern x) =+ T.RecursivePattern p2+replaceElement (T.RecursivePatternElement p1) (T.RecursivePatternElement p2) (T.RecursivePatternElement x) =+ T.RecursivePatternElement x+replaceElement p1 p2 x = x++updateValue :: [T.Token] -> (T.Token, T.Token) -> [T.Token]+updateValue from patternMatch = map (uncurry replaceElement patternMatch) from++-- | Compare 2 patterns+comparePattern :: [T.Token] -> [T.Token] -> [T.Token] -> Bool+comparePattern to chunk patterns =+ let chunk' = (filter Tokenizer.newLines (filter Tokenizer.spaces chunk))+ to' = (filter Tokenizer.spaces to)+ in ((length chunk' == length to') && all compareElements (zip chunk' to'))++compareElements :: (T.Token, T.Token) -> Bool+compareElements (T.Var a, T.Pattern b _) = True+compareElements (T.Entitiy a, T.Pattern b _) = True+compareElements (T.Pattern b _, T.Entitiy a) = True+compareElements (T.RecursivePattern _, T.RecursivePattern _) = True+compareElements (T.RecursivePatternElement _, T.RecursivePattern _) = True+compareElements (T.RecursivePattern _, T.RecursivePatternElement _) = True+compareElements (a, b) = a == b++------------------------------ Test Driver -------------------------------------+-- | For testing: first uncomment the module definition to make this module the+-- Main module. Usage: ghc Sugarer.hs; ./Sugarer <element-file> <substance-file>+main :: IO ()+main = do+ [elementFile, substanceFile] <- getArgs+ elementIn <- readFile elementFile+ let elementRes = D.parseElement elementFile elementIn++ case elementRes of+ Right elementEnv -> do+ substanceIn <- readFile substanceFile+ putStrLn "Tokenized Sugared Substance: \n"+ -- print(sugarStmts substanceIn elementEnv)+ writeFile "syntacticSugarExamples/output" (sugarStmts substanceIn elementEnv)+ return ()+ Left e -> error $ "Element compilation error: " ++ show e
+ src/Tokenizer.hs view
@@ -0,0 +1,166 @@+-- | "Tokenizer" contains all the functions for tokenization of Substance+-- programs and patterns as part of the syntactic sugar mechanism+-- Author: Dor Ma'ayan, August 2018++{-# OPTIONS_HADDOCK prune #-}+module Tokenizer where+--module Main (main) where -- for debugging purposes++import Utils+import System.Process+import Control.Monad (void)+import Data.Void+import System.IO -- read/write to file+import System.Environment+import Control.Arrow ((>>>))+import Debug.Trace+import Data.Functor.Classes+import Data.List+import Data.List.Split+import Data.Maybe (fromMaybe)+import Data.Typeable+import Text.Megaparsec+import Text.Megaparsec.Char+import Control.Monad.Combinators.Expr+import Env++import qualified Data.Map.Strict as M+import qualified Text.Megaparsec.Char.Lexer as L+import qualified SubstanceTokenizer as T++------------------------------ Tokenization ------------------------------------+-- | Get as an input from and to string notataions and returns refined tokenized+-- versions of them++-- | Tokenize the given string using the Substance tokenizer, returns pure token+-- list as it is given from the tokenizer itself+tokenize :: String -> [T.Token]+tokenize = T.alexScanTokens++-- | Given a string representing a sugared Substance program, tokenize it and+-- and refine the tokens into patterns and entities+tokenizeSugaredSubstance :: String -> VarEnv -> [T.Token]+tokenizeSugaredSubstance prog dsllEnv =+ let allDsllEntities = typeCtorNames dsllEnv+ allSnrEntities = concatMap entitiesSnr (stmtNotations dsllEnv)+ tokenized = tokenize prog+ tokenized' = foldl (refineByEntity allDsllEntities allSnrEntities) [] tokenized+ in tokenized'++-- getEntities :: StmtNotationRule -> [T.Token]+-- getEntities s = entitiesSnr s++-- | Translate string notation patterns into tokenized patterns which ignores+-- spaces and properly recognize patterns and Dsll entities+translatePatterns :: (String,String) -> VarEnv -> ([T.Token],[T.Token],[T.Token],[T.Token])+translatePatterns (fromStr, toStr) dsllEnv =+ let from = refineByRecursivePatternElement (foldl (refineDSLLToken dsllEnv) [] (tokenize fromStr))+ patterns = filter notPatterns from+ to = foldl (refineByPattern patterns) [] (tokenize toStr)+ entities = filter notEntities to+ in (from, to, patterns, entities)++refineByRecursivePatternElement :: [T.Token] -> [T.Token]+refineByRecursivePatternElement tokens = let dividedToLines = split (onSublist [T.NewLine]) tokens+ refinedDividedToLines = map replaceToRecursivePattern dividedToLines+ in concat refinedDividedToLines++replaceToRecursivePattern chunk =+ if T.RecursivePatternElement [] `elem` chunk then+ [T.RecursivePatternElement (wrap1 chunk)]+ else chunk++wrap1 :: [T.Token] -> [T.Token]+wrap1 tokens = map replaceToSingleElement tokens++replaceToSingleElement (T.RecursivePatternElement l) = T.SinglePatternElement l+replaceToSingleElement a = a+++notPatterns :: T.Token -> Bool+notPatterns (T.Pattern t b) = True+notPatterns token = False++notAllPatterns :: T.Token -> Bool+notAllPatterns (T.RecursivePattern t) = True+notAllPatterns (T.RecursivePatternElement t) = True+notAllPatterns token = notPatterns token++notEntities :: T.Token -> Bool+notEntities (T.Entitiy e) = True+notEntities token = False++spaces :: T.Token -> Bool+spaces T.Space = False+spaces token = True++newLines :: T.Token -> Bool+newLines T.NewLine = False+newLines token = True++refineByPattern :: [T.Token] -> [T.Token] -> T.Token -> [T.Token]+refineByPattern patterns tokens (T.Var v) =+ if v `elem` map (\(T.Pattern p b) -> p) patterns+ then tokens ++ [T.Pattern v False]+ else tokens ++ [T.Entitiy v]++refineByPattern patterns tokens t = tokens ++ [t]++refineByEntity :: [String] -> [T.Token] -> [T.Token] -> T.Token -> [T.Token]+refineByEntity dsllEntities snrEntities tokens (T.Var v) =+ if v `elem` dsllEntities || T.Entitiy v `elem` snrEntities+ then tokens ++ [T.Entitiy v]+ else tokens ++ [T.Pattern v False]++refineByEntity _ _ tokens t = tokens ++ [t]+++refineDSLLToken :: VarEnv -> [T.Token] -> T.Token -> [T.Token]+refineDSLLToken dsllEnv tokens (T.Var v) = if isDeclared v dsllEnv then+ tokens ++ [T.DSLLEntity v]+ else tokens ++ [T.Pattern v False]+refineDSLLToken dsllEnv tokens t = tokens ++ [t]++-- |This function identify the pattern vars in the sugared notatation in the+-- StmtNotation in the DSLL+identifyPatterns :: [T.Token] -> [T.Token] -> [T.Token]+identifyPatterns tokensSugared tokenDesugared =+ foldl (identifyPattern tokenDesugared) [] tokensSugared++identifyPattern :: [T.Token] -> [T.Token] -> T.Token -> [T.Token]+identifyPattern tokenDesugared tokensSugared (T.Var v) =+ if T.Var v `elem` tokenDesugared then+ tokensSugared ++ [T.Pattern v False]+ else+ tokensSugared ++ [T.Var v]+identifyPattern tokenDesugared tokensSugared token = tokensSugared ++ [token]++-- | Retranslate a token list into a program+reTokenize :: [T.Token] -> String+reTokenize = foldl translate ""++-- | Translation function from a specific token back into String+-- In use after the notation replacements in order to translate back to+-- a Substance program+translate :: String -> T.Token -> String+translate prog T.Bind = prog ++ ":= "+translate prog T.NewLine = prog ++ "\n"+translate prog T.PredEq = prog ++ "<->"+translate prog T.ExprEq = prog ++ "="+translate prog T.Comma = prog ++ ","+translate prog T.Lparen = prog ++ "("+translate prog T.Rparen = prog ++ ")"+translate prog T.Space = prog ++ " "+translate prog (T.Sym c) = prog ++ [c] ++ " "+translate prog (T.Var v) = prog ++ v+translate prog (T.Comment c) = prog ++ c+translate prog (T.StartMultiComment c) = prog ++ c+translate prog (T.EndMultiComment c) = prog ++ c+translate prog (T.Label l) = prog ++ l+translate prog (T.AutoLabel l) = prog ++ l+translate prog (T.DSLLEntity d) = prog ++ d+translate prog (T.Pattern p b) = prog ++ p ++ " "+translate prog (T.Entitiy e) = prog ++ e ++ " "+translate prog (T.RecursivePatternElement lst) = prog ++ concatMap (translate "") lst+translate prog (T.RecursivePattern lst) = prog ++ concatMap (translate "") lst+translate prog (T.SinglePatternElement lst) = prog ++ concatMap (translate "") lst
+ src/Transforms.hs view
@@ -0,0 +1,690 @@+{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# OPTIONS_HADDOCK prune #-}+++module Transforms where++{-+Naming conventions in this file:++Postfixes specifying argument types: + P: point+ S: segment+ B: blob (simply connected region represented by a list of vertices)+ G: polygon+ A: angle in degrees++Other postfixes:+ Offs: offset, specifies exact separation amount+ Pad: padding, specifies minimum separation amount++Prefix e: post-level energy++When a function takes multiple blobs/polygons as inputs, name them as A, B, etc. in order++When using angle to specify an axis, let theta be the input angle in radians+(converted from degrees), then the axis in question is the line containing vector+(cos theta, sin theta).++-}++import Utils+import Debug.Trace+import Data.List (nub, sort, findIndex, find, maximumBy, foldl')+import qualified Data.Map.Strict as M++import GHC.Generics+import Data.Aeson (FromJSON, ToJSON, toJSON)+--import Par++default (Int, Float)++-- a, b, c, d, e, f as here:+-- https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/transform+data HMatrix a = HMatrix {+ xScale :: a, -- a+ xSkew :: a, -- c -- What are c and b called?+ ySkew :: a, -- b+ yScale :: a, -- d+ dx :: a, -- e+ dy :: a -- f+} deriving (Generic, Eq)++instance Show a => Show (HMatrix a) where+ show m = "[ " ++ show (xScale m) ++ " " ++ show (xSkew m) ++ " " ++ show (dx m) ++ " ]\n" +++ " " ++ show (ySkew m) ++ " " ++ show (yScale m) ++ " " ++ show (dy m) ++ " \n" +++ " 0.0 0.0 1.0 ]"++instance (FromJSON a) => FromJSON (HMatrix a)+instance (ToJSON a) => ToJSON (HMatrix a)++idH :: (Autofloat a) => HMatrix a+idH = HMatrix {+ xScale = 1,+ xSkew = 0,+ ySkew = 0,+ yScale = 1,+ dx = 0,+ dy = 0+}++-- First row, then second row+hmToList :: (Autofloat a) => HMatrix a -> [a]+hmToList m = [ xScale m, xSkew m, dx m, ySkew m, yScale m, dy m ]++listToHm :: (Autofloat a) => [a] -> HMatrix a+listToHm l = if length l /= 6 then error "wrong length list for hmatrix"+ else HMatrix { xScale = l !! 0, xSkew = l !! 1, dx = l !! 2,+ ySkew = l !! 3, yScale = l !! 4, dy = l !! 5 }++hmDiff :: (Autofloat a) => HMatrix a -> HMatrix a -> a+hmDiff t1 t2 = let (l1, l2) = (hmToList t1, hmToList t2) in+ norm $ l1 -. l2++applyTransform :: (Autofloat a) => HMatrix a -> Pt2 a -> Pt2 a+applyTransform m (x, y) = (x * xScale m + y * xSkew m + dx m, x * ySkew m + y * yScale m + dy m)++infixl ##+(##) :: (Autofloat a) => HMatrix a -> Pt2 a -> Pt2 a+(##) = applyTransform++-- General functions to work with transformations++-- Do t2, then t1. That is, multiply two homogeneous matrices: t1 * t2+composeTransform :: (Autofloat a) => HMatrix a -> HMatrix a -> HMatrix a+composeTransform t1 t2 = HMatrix { xScale = xScale t1 * xScale t2 + xSkew t1 * ySkew t2,+ xSkew = xScale t1 * xSkew t2 + xSkew t1 * yScale t2,+ ySkew = ySkew t1 * xScale t2 + yScale t1 * ySkew t2,+ yScale = ySkew t1 * xSkew t2 + yScale t1 * yScale t2,+ dx = xScale t1 * dx t2 + xSkew t1 * dy t2 + dx t1,+ dy = yScale t1 * dy t2 + ySkew t1 * dx t2 + dy t1 }+-- TODO: test that this gives expected results for two scalings, translations, rotations, etc.++infixl 7 #+(#) :: (Autofloat a) => HMatrix a -> HMatrix a -> HMatrix a+(#) = composeTransform++-- Compose all the transforms in RIGHT TO LEFT order:+-- [t1, t2, t3] means "do t3, then do t2, then do t1" or "t1 * t2 * t3"+composeTransforms :: (Autofloat a) => [HMatrix a] -> HMatrix a+composeTransforms ts = foldr composeTransform idH ts++-- Specific transformations++rotationM :: (Autofloat a) => a -> HMatrix a+rotationM radians = idH { xScale = cos radians, + xSkew = -(sin radians),+ ySkew = sin radians,+ yScale = cos radians+ }++translationM :: (Autofloat a) => Pt2 a -> HMatrix a+translationM (x, y) = idH { dx = x, dy = y }++scalingM :: (Autofloat a) => Pt2 a -> HMatrix a+scalingM (cx, cy) = idH { xScale = cx, yScale = cy }++rotationAboutM :: (Autofloat a) => a -> Pt2 a -> HMatrix a+rotationAboutM radians (x, y) = + -- Make the new point the new origin, do a rotation, then translate back+ composeTransforms [translationM (x, y), rotationM radians, translationM (-x, -y)]++shearingX :: (Autofloat a) => a -> HMatrix a+shearingX lambda = idH { xSkew = lambda }++shearingY :: (Autofloat a) => a -> HMatrix a+shearingY lambda = idH { ySkew = lambda }++------ Solve for final parameters++-- See PR for documentation+-- Note: returns angle in range [0, 2pi)+paramsOf :: (Autofloat a) => HMatrix a -> (a, a, a, a, a) -- There could be multiple solutions+paramsOf m = let (sx, sy) = (norm [xScale m, ySkew m], norm [xSkew m, yScale m]) in -- Ignore negative scale factors+ let theta = atan (ySkew m / (xScale m + epsd)) in -- Prevent atan(0/0) = NaN+ -- atan returns an angle in [-pi, pi]+ (sx, sy, theta, dx m, dy m)++paramsToMatrix :: (Autofloat a) => (a, a, a, a, a) -> HMatrix a+paramsToMatrix (sx, sy, theta, dx, dy) = -- scale then rotate then translate+ composeTransforms [translationM (dx, dy), rotationM theta, scalingM (sx, sy)]++toParallelogram :: (Autofloat a) => (a, a, a, a, a, a) -> HMatrix a+toParallelogram (w, h, rotation, x, y, shearAngle) =+ if shearAngle < 10**(-5) then error "shearAngle can't be 0, tangent will NaN" else+ composeTransforms [translationM (x, y),+ rotationM rotation,++ -- translationM (-w/2, -h/2),+ shearingX (1 / tan shearAngle),+ -- translationM (w/2, h/2),++ scalingM (w, h)+ ]++unitSq :: (Autofloat a) => [Pt2 a]+unitSq = [(0.5, 0.5), (-0.5, 0.5), (-0.5, -0.5), (0.5, -0.5)]++circlePoly :: (Autofloat a) => a -> [Pt2 a]+circlePoly r = let +-- currently doesn't use r, so that #sides remains the same throughout opt.+-- TODO: might want to depend on radius of the original circle in some way?+ sides :: Int+ sides = max 8 $ floor (64 / 4.0)+ indices :: [Int]+ indices = [0..sides-1]+ angles = map (\i -> (r2f i) / (r2f sides) * 2.0 * pi) indices+ pts = map (\a -> (cos a, sin a)) angles+ in pts++-- Sample a circle about the origin with some density according to its radius+sampleUnitCirc :: (Autofloat a) => a -> [Pt2 a]+sampleUnitCirc r = if r < 0.01 then [(0, 0)] else []++testTriangle :: (Autofloat a) => [Pt2 a]+testTriangle = [(0, 0), (100, 0), (50, 50)]++testNonconvex :: (Autofloat a) => [Pt2 a]+testNonconvex = [(0, 0), (100, 0), (50, 50), (100, 100), (0, 100)]++-- TODO: the samples be transformed along by transforming here?+transformPoly :: (Autofloat a) => HMatrix a -> Polygon a -> Polygon a+transformPoly m (blobs, holes, _, samples) = let+ transformedBlobs = map (map (applyTransform m)) blobs+ in (+ transformedBlobs, + map (map (applyTransform m)) holes,+ getBBox (concat transformedBlobs),+ map (applyTransform m) samples+ )++transformSimplePoly :: (Autofloat a) => HMatrix a -> [Pt2 a] -> [Pt2 a]+transformSimplePoly m = map (applyTransform m)++-- Pointing to the right. Note: doesn't try to approximate the "inset" part of the arrowhead+rtArrowheadPoly :: (Autofloat a) => a -> [Pt2 a]+rtArrowheadPoly c = let x = 2 * c in -- c is the thickness of the line+ let twox = x*2 in+ [(-x, x/4), -- Stem top+ (-twox, twox), -- Top left+ (twox, 0), -- Point of arrownead+ (-twox, -twox), -- Bottom left+ (-x, -x/4)] -- Stem bottom++ltArrowheadPoly :: (Autofloat a) => a -> [Pt2 a]+ltArrowheadPoly c = reverse $ map flipX $ rtArrowheadPoly c+ where flipX (x, y) = (-x, y)+ -- Reverse so the line polygon can join the stem bottom with the stem bottom++-- | Make a rectangular polygon of a line segment, accounting for its thickness and arrowheads+-- (Is this usable with autodiff?)+extrude :: (Autofloat a) => a -> Pt2 a -> Pt2 a -> Bool -> Bool -> [Pt2 a]+extrude c x y leftArr rightArr = + let dir = normalize' (y -: x)+ normal = rot90 dir -- normal vector to the line segment+ offset = (c / 2) *: normal -- find offset for each endpoint++ halfLen = mag (y -: x) / 2.0 -- Calculate arrowhead position+ trLeft = (-halfLen) *: dir+ trRight = halfLen *: dir++ left = if leftArr + then translate2 trLeft (ltArrowheadPoly c)+ else [x -: offset, x +: offset] -- Note: order matters for making the polygon+ right = if rightArr+ then translate2 trRight (rtArrowheadPoly c)+ else [y +: offset, y -: offset] + in left ++ right++------ Energies on polygons ------++---- some helpers below ----++type LineSeg a = (Pt2 a, Pt2 a)+type Blob a = [Pt2 a] -- temporary type for polygon. Connected, no holes+-- TODO: assuming that the positive shapes don't overlap and the negative shapes don't overlap (check this)+-- (positive shapes, negative shapes, bbox, samples)+type Polygon a = ([Blob a], [Blob a], (Pt2 a, Pt2 a), [Pt2 a])++emptyPoly :: Autofloat a => Polygon a+emptyPoly = ([], [], ((posInf, posInf), (negInf, negInf)), [])++toPoly :: Autofloat a => [Pt2 a] -> Polygon a+toPoly pts = ([pts], [], getBBox pts, sampleB numSamples pts)++posInf :: Autofloat a => a+posInf = 1 / 0++negInf :: Autofloat a => a+negInf = -1 / 0++-- input point, query parametric t+gettPS :: Autofloat a => Pt2 a -> LineSeg a -> a+gettPS p (a,b) = let+ v_ab = b -: a+ projl = v_ab `dotv` (p -: a)+ in projl / (magsq v_ab)++closestPointPS :: Autofloat a => Pt2 a -> LineSeg a -> Pt2 a+closestPointPS p (a,b) = let+ t = gettPS p (a,b) in+ if t<0.0 then a else if t>=1 then b else let v_ab = b -: a in+ a +: (t *: v_ab)++closestPointPG :: Autofloat a => Pt2 a -> Polygon a -> Pt2 a+closestPointPG p poly = let+ segments = getSegmentsG poly+ --+ mapf s = closestPointPS p s+ cps = map mapf segments -- parmap?+ --+ redf p1 p2 = let+ d1 = dsqPP p1 p+ d2 = dsqPP p2 p+ in if d1 <= d2 then p1 else p2+ in foldl' redf (cps!!0) cps -- reduce?++normS :: Autofloat a => LineSeg a -> Pt2 a+normS (p1, p2) = normalize' $ rot90 $ p2 -: p1++-- test if two segments intersect. Doesn't calculate for ix point though.+ixSS :: Autofloat a => LineSeg a -> LineSeg a -> Bool+ixSS (a,b) (c,d) = let+ ncd = rot90 $ d -: c+ a_cd = ncd `dotv` (a -: c)+ b_cd = ncd `dotv` (b -: c)+ nab = rot90 $ b -: a+ c_ab = nab `dotv` (c -: a)+ d_ab = nab `dotv` (d -: a)+ in ((a_cd>=0&&b_cd<=0) || (a_cd<=0&&b_cd>=0)) && + ((c_ab>=0&&d_ab<=0) || (c_ab<=0&&d_ab>=0))++getSegmentsB :: Autofloat a => Blob a -> [LineSeg a]+getSegmentsB pts = let + pts' = rotateList pts+ in zip pts pts'++getSegmentsG :: Autofloat a => Polygon a -> [LineSeg a]+getSegmentsG (bds, hs, _, _) = let+ bdsegments = map (\b->getSegmentsB b) bds+ hsegments = map (\h->getSegmentsB h) hs+ in concat [concat bdsegments, concat hsegments]++-- OLD+-- blob inside/outside test wo testing bbox first+isInB'' :: Autofloat a => Blob a -> Pt2 a -> Bool+isInB'' pts (x0,y0) = let+ diffp = map (\(x,y)->(x-x0,y-y0)) pts+ getAngle (x,y) = atan2 y x + angles = map getAngle diffp+ angles' = rotateList angles+ sweeps = map (\(a,b)->b-a) $ zip angles angles'+ adjust sweep = + if sweep>pi then sweep-2*pi+ else if sweep<(-pi) then 2*pi+sweep+ else sweep+ sweepAdjusted = map adjust sweeps+ -- if inside pos poly, res would be 2*pi,+ -- if inside neg poly, res would be -2*pi,+ -- else res would be 0+ res = foldl' (+) 0.0 sweepAdjusted+ in res>pi || res<(-pi)++-- A cheaper implementation of inside/outside test, found at+-- http://geomalgorithms.com/a03-_inclusion.html+isInB' :: Autofloat a => Blob a -> Pt2 a -> Bool+isInB' pts p@(x0, y0) = let+ segments = getSegmentsB pts+ wnf (a@(x1,y1), b@(x2,y2)) = + if (y1>y0 && y2>y0) || (y1<y0 && y2<y0) then 0+ else if (rot90(b-:a))`dotv`(p-:a) > 0 then 1 + else (-1)+ wn = foldl' (+) 0 $ map wnf segments+ in if wn==0 then False else True++-- general, direct inside/outside test+isInG' :: Autofloat a => Polygon a -> Pt2 a -> Bool+isInG' (bds, hs, _, _) p = let+ inb = foldl' (||) False $ map (\b->isInB' b p) bds+ inh = foldl' (||) False $ map (\h->isInB' h p) hs+ in (inb) && (not inh)++-- inside/outside test w polygon by first testing against bbox.+isInG :: Autofloat a => Polygon a -> Pt2 a -> Bool+isInG poly@(_,_,bbox,_) p = if inBBox bbox p then isInG' poly p else False++-- isOutG :: Autofloat a => Polygon a -> Pt2 a -> a -> Bool+-- isOutG poly p ofs = (not $ isInG' poly p) && (dsqGP poly p 0 >= ofs)++getBBox :: Autofloat a => Blob a -> (Pt2 a, Pt2 a)+getBBox pts = let+ foldfn :: Autofloat a => (Pt2 a, Pt2 a) -> Pt2 a -> (Pt2 a, Pt2 a)+ foldfn ((xlo,ylo), (xhi,yhi)) (x, y) = + ( (min xlo x, min ylo y), (max xhi x, max yhi y) )+ in foldl' foldfn ((posInf, posInf), (negInf, negInf)) pts++-- returns the center of the polygon bbox+getCenter :: Autofloat a => Polygon a -> Pt2 a+getCenter (_,_,((xlo,ylo), (xhi,yhi)),_) = ((xhi+xlo)/2, (yhi+ylo)/2)++getDiameter2' :: Autofloat a => [Pt2 a] -> a+getDiameter2' pts = case pts of+ [] -> 0+ p:pts -> foldl' max 0 $ map (dsqPP p) pts++-- a shape's diameter is defined as the length of the longest segment connecting +-- p1, p2, both of which are on the shape's boundary.+getDiameter :: Autofloat a => Polygon a -> a+getDiameter (bds,hs,_,_) = let+ vertices = (concat bds) ++ (concat hs)+ in sqrt $ getDiameter2' vertices++-- true if in bbox and far enough from boundary+inBBox :: Autofloat a => (Pt2 a, Pt2 a) -> Pt2 a -> Bool+inBBox ((xlo, ylo), (xhi, yhi)) (x,y) = let+ res = x >= xlo && x <= xhi &&+ y >= ylo && y <= yhi+ in res++scaleB :: Autofloat a => a -> Blob a -> Blob a+scaleB k b = map (scaleP k) b++-- sample points along segment with interval.+sampleS :: Autofloat a => a -> LineSeg a -> [Pt2 a]+sampleS numSamplesf (a, b) = let+ -- l = mag $ b -: a+ numSamples :: Int+ numSamples = (floor numSamplesf) + 1--floor $ l/interval+ inds = map realToFrac [0..numSamples-1]+ ks = map (/(realToFrac numSamples)) $ inds+ in map (lerpP a b) ks++sampleB :: Autofloat a => Int -> Blob a -> [Pt2 a]+sampleB numSamples blob = let+ numSamplesf = r2f numSamples+ segments = getSegmentsB blob+ circumfrence = foldl' (+) 0.0 $ map (\(a,b)->dist a b) segments+ seglengths = map (\(a,b)->dist a b) $ segments+ samplesEach = map (\l->l/circumfrence*numSamplesf) seglengths+ zp = zip segments samplesEach+ in concat $ map (\(seg, num) -> sampleS num seg) zp++-- TODO: be absolutely sure #samples are same as input #+sampleG :: Autofloat a => Int -> Polygon a -> [Pt2 a]+sampleG numSamples poly@(bds, hs, _, _) = let + numSamplesf = r2f numSamples+ segments = getSegmentsG poly+ circumfrence = foldl' (+) 0.0 $ map (\(a,b)->dist a b) segments+ seglengths = map (\(a,b)->dist a b) $ segments+ samplesEach = map (\l->l/circumfrence*numSamplesf) seglengths+ zp = zip segments samplesEach+ in concat $ map (\(seg, num) -> sampleS num seg) zp++---- dsq functions ----++dsqPP :: Autofloat a => Pt2 a -> Pt2 a -> a+dsqPP a b = magsq $ b -: a++dsqSP :: Autofloat a => LineSeg a -> Pt2 a -> a+dsqSP (a,b) p = let t = gettPS p (a,b) in+ if t<0 then dsqPP a p+ else if t>1 then dsqPP b p+ else (**2) $ (normS (a,b)) `dotv` (p -: a)++dsqSS :: Autofloat a => LineSeg a -> LineSeg a -> a+dsqSS (a,b) (c,d) = if ixSS (a,b) (c,d) then 0 else let+ da = dsqSP (c,d) a + db = dsqSP (c,d) b + dc = dsqSP (a,b) c + dd = dsqSP (a,b) d + in min (min da db) (min dc dd)++dsqBP :: Autofloat a => Blob a -> Pt2 a -> a+dsqBP b p = let+ segments = getSegmentsB b+ -- min dist to vertex+ d2v = foldl' min posInf $ map (\q -> magsq $ p -: q) b+ -- min dist to segment (if closest point falls within segment)+ d2s = foldl' min posInf $ map (\s@(a,b) -> let t = gettPS p s in+ if t>1 || t<0 then posInf else (**2) $ (normS (a,b)) `dotv` (p -: a)) segments+ in min d2v d2s++dsqGP :: Autofloat a => Polygon a -> Pt2 a -> a+dsqGP (bds, hs, _, _) p = let+ dsqBD = foldl' min posInf $ map (\b -> dsqBP b p) bds+ dsqHS = foldl' min posInf $ map (\h -> dsqBP h p) hs+ in min dsqBD dsqHS++-- signed distance squared between polygons: +-- only the magnitude matches with dsq. Negative when inside A.+signedDsqGP :: Autofloat a => Polygon a -> Pt2 a -> a+signedDsqGP poly p = let + dsq = dsqGP poly p+ inside = if dsq < epsd then True else isInG poly p+ in if inside then -dsq else dsq++dsqBS :: Autofloat a => Blob a -> LineSeg a -> a+dsqBS b s = foldl' min posInf $ + map (\e -> dsqSS e s) $ getSegmentsB b++dsqBB :: Autofloat a => Blob a -> Blob a -> a+dsqBB b1 b2 = let+ min1 = foldl' min posInf $ map (\e -> dsqBS b2 e) $ getSegmentsB b1+ in min1++-- distance squared+dsqGG :: Autofloat a => Polygon a -> Polygon a -> a+dsqGG (bds1, hs1, _, _) (bds2, hs2, _, _) = let+ b1b2 = foldl' min posInf $ map (\b->foldl' min posInf $ map (\b'->dsqBB b b') bds1) bds2+ b1h2 = foldl' min posInf $ map (\b->foldl' min posInf $ map (\b'->dsqBB b b') bds1) hs2+ b2b1 = foldl' min posInf $ map (\b->foldl' min posInf $ map (\b'->dsqBB b b') bds2) bds1+ b2h1 = foldl' min posInf $ map (\b->foldl' min posInf $ map (\b'->dsqBB b b') bds2) hs1+ in min (min b1b2 b1h2) (min b2b1 b2h1)++-- (helper) encourages the line containing two points to be parallel to the specified axis.+alignPPA :: Autofloat a => Pt2 a -> Pt2 a -> a -> a+alignPPA a b angle = let+ angle_radians = angle * pi / 180.0+ dirN = rot90 (cos angle_radians, sin angle_radians)+ in (**2) $ (a `dotv` dirN) - (b `dotv` dirN)++-- (helper) Let a' and b' be projections of a and b onto the axis. Encourages positions of a, b +-- such that a' appears before b' on the axis+-- ex: when angle = 0, encourages a to be on the left of b.+-- when angle = 180, encourages a to be on the right of b+orderPPA :: Autofloat a => Pt2 a -> Pt2 a -> a -> a+orderPPA a b angle = let+ angle_radians = angle * pi / 180.0+ dir = (cos angle_radians, sin angle_radians)+ in (**2) $ max 0 $ (a `dotv` dir) - (b `dotv` dir)++-- samples per polygon+numSamples :: Int+numSamples = 200++------------ some energy "building blocks" ------------++---- type 1: dsq integral along boundary functions ----++-- penalize part of B's boundary that's inside A+dsqBinA :: Autofloat a => Polygon a -> Polygon a -> a+dsqBinA bA bB@(_,_,_,samplesB) = let+ samplesIn = filter (\p -> isInG bA p) $ samplesB+ in foldl' (+) 0.0 $ map (\p -> dsqGP bA p) samplesIn++-- penalize part of B's boundary that's outside A+dsqBoutA :: Autofloat a => Polygon a -> Polygon a -> a+dsqBoutA bA bB@(_,_,_,samplesB) = let+ samplesOut = filter (\p -> not $ isInG bA p) $ samplesB+ in foldl' (+) 0.0 $ map (\p -> dsqGP bA p) samplesOut++---- type 2: min/max dsq on boundary functions ----++-- minimum (signed distance squared) between polygons based on sampling+minSignedDsqGG :: Autofloat a => Polygon a -> Polygon a -> a+minSignedDsqGG polyA polyB@(_,_,_,samplesB) = + foldl' min posInf $ map (signedDsqGP polyA) samplesB++-- maximum (signed distance squared) between polygons based on sampling+maxSignedDsqGG :: Autofloat a => Polygon a -> Polygon a -> a+maxSignedDsqGG polyA polyB@(_,_,_,samplesB) =+ foldl' max negInf $ map (signedDsqGP polyA) samplesB++----------------- top-level query energies -----------------++---- Energies using min/max dsq on boundary (type 2) ----++-- eBinAOffs, eBoutAOffs: Energy lowest when minimum/maximum signed distance is at ofs pixels.+-- Both functions have similar runtime compared to other inside/outside energies+-- Both are a bit "unstable" (shapes make unexpected big jumps), likely because of how they're defined+-- to consider only contribution from one sample.++-- Lowest when A contains B with exactly ofs number of pixels between their boundaries.+-- ofs > 0: A contains B with ofs pixels of padding (general use case)+-- ofs < 0: A doesn't completely contain B, the point on B furthest from A is |ofs| pixels away.+-- ofs = 0: an alternative containment+tangent energy+eBinAOffs :: Autofloat a => Polygon a -> Polygon a -> a -> a+eBinAOffs polyA polyB ofs = let+ sdsq = maxSignedDsqGG polyA polyB+ sign = if sdsq >= 0 then 1.0 else -1.0+ sdist = (*sign) $ sqrt $ abs sdsq+ in (sdist + ofs)**2++-- Lowest when A, B disjoint with exactly ofs number of pixels between their boundaries.+-- ofs > 0: A, B disjoint with ofs pixels of padding (general use case)+-- ofs < 0: A and B intersect, B "penetrates into A" |ofs| pixels+-- ofs = 0: an alternative disjoint+tangent energy+eBoutAOffs :: Autofloat a => Polygon a -> Polygon a -> a -> a+eBoutAOffs polyA polyB ofs = let+ sdsq = minSignedDsqGG polyA polyB+ sign = if sdsq >= 0 then 1.0 else -1.0+ sdist = (*sign) $ sqrt $ abs sdsq+ in (sdist - ofs)**2++-- energy lowest when either of the above two energies are lowest+-- used for specifying amt of distance to boundary but don't care about inside/outside+-- ex: when placing labels+eOffs :: Autofloat a => Polygon a -> Polygon a -> a -> a+eOffs polyA polyB ofs = let+ eIn = eBinAOffs polyA polyB ofs+ eOut = eBoutAOffs polyA polyB ofs+ in min eIn eOut++-- Same as eOffs except B is a point+eOffsP :: Autofloat a => Polygon a -> Pt2 a -> a -> a+eOffsP poly pt ofs = let+ d = sqrt $ dsqGP poly pt+ in (d - ofs)**2++-- Same as eOffs except both inputs are points+eOffsPP :: Autofloat a => Pt2 a -> Pt2 a -> a -> a+eOffsPP p1 p2 ofs = let+ d = sqrt $ dsqPP p1 p2+ in (d - ofs)**2++-- eBinAPad, eBoutAPad: Energy lowest when minimum/maximum signed distance is at least ofs pixels+-- (compare to eBinAOffs, eBoutAOffs)++-- ofs > 0: A contains B with at least ofs pixels of padding (general use case)+-- ofs = 0: an alternative containment energy+eBinAPad :: Autofloat a => Polygon a -> Polygon a -> a -> a+eBinAPad polyA polyB ofs = let+ sdsq = maxSignedDsqGG polyA polyB+ sign = if sdsq >= 0 then 1.0 else -1.0+ sdist = (*sign) $ sqrt $ abs sdsq+ in (max 0 $ sdist + ofs)**2++-- ofs > 0: A, B disjoint with at least ofs pixels of padding (general use case)+-- ofs = 0: an alternative disjoint energy+eBoutAPad :: Autofloat a => Polygon a -> Polygon a -> a -> a+eBoutAPad polyA polyB ofs = let+ sdsq = minSignedDsqGG polyA polyB+ sign = if sdsq >= 0 then 1.0 else -1.0+ sdist = (*sign) $ sqrt $ abs sdsq+ in (min 0 $ sdist - ofs)**2++-- energy lowest when either eBinAPad or eBoutAPad is lowest+-- used for specifying amt of minimum separation to boundary but don't care about inside/outside+ePad :: Autofloat a => Polygon a -> Polygon a -> a -> a+ePad polyA polyB ofs = let+ eIn = eBinAPad polyA polyB ofs+ eOut = eBoutAPad polyA polyB ofs+ in min eIn eOut++---- energies based on integral of dsq along boundary ----++-- A contain B+eAcontainB :: Autofloat a => Polygon a -> Polygon a -> a+eAcontainB bA bB = let+ eAinB = dsqBinA bB bA+ eBoutA = dsqBoutA bA bB+ in eAinB + eBoutA++-- A, B disjoint. Might need something better, as not all local mins correspond to satisfaction of obj.+-- resulting in two shapes overlap even more+eABdisj :: Autofloat a => Polygon a -> Polygon a -> a+eABdisj bA bB = let+ eAinB = dsqBinA bB bA+ eBinA = dsqBinA bA bB+ in eAinB + eBinA ++{- commented these out bc are just addition of above energies. ++-- A and B tangent, B inside A+eBinAtangent :: Autofloat a => Polygon a -> Polygon a -> a+eBinAtangent bA bB = let+ eContainment = eAcontainB bA bB+ eABbdix = dsqGG bA bB+ in eContainment + eABbdix++-- A and B tangent, B outside A+eBoutAtangent :: Autofloat a => Polygon a -> Polygon a -> a+eBoutAtangent bA bB = let+ eDisjoint = eABdisj bA bB+ eABbdix = dsqGG bA bB+ in eDisjoint + eABbdix+-}++---- Energies defined on polygon size (diameter), see function getDiameter ----++-- penalize if the diameter of poly is too large.+eMaxSize :: Autofloat a => Polygon a -> a -> a+eMaxSize poly size = let+ d = getDiameter poly+ in (**2) $ max 0 $ d - size++-- penalize if the diameter of poly is too small.+eMinSize :: Autofloat a => Polygon a -> a -> a+eMinSize poly size = let+ d = getDiameter poly+ in (**2) $ max 0 $ size - d++-- penalize if two shapes have different diameters+eSameSize :: Autofloat a => Polygon a -> Polygon a -> a+eSameSize bA bB = let+ d1 = getDiameter bA+ d2 = getDiameter bB+ in (d1 - d2) ** 2++-- penalize if A is larger than B+eSmallerThan :: Autofloat a => Polygon a -> Polygon a -> a+eSmallerThan bA bB = let+ d1 = getDiameter bA+ d2 = getDiameter bB+ in (max 0 $ d1 - d2) ** 2 -- no penalty if d1 <= d2++---- Other energies (related to alignment and ordering) ----++-- currently uses center of bbox to represent polygon position.++-- encourages A and B to align along some axis (input angle in degrees)+-- in other words, encourages the line connecting A and B to be parallel to the given axis+eAlign :: Autofloat a => Polygon a -> Polygon a -> a -> a+eAlign bA bB angle = alignPPA (getCenter bA) (getCenter bB) angle++-- encourages A and B to order along some axis (input angle in degrees)+-- more abt ordering near function orderPPA+eOrder :: Autofloat a => Polygon a -> Polygon a -> a -> a+eOrder bA bB angle = orderPPA (getCenter bA) (getCenter bB) angle
src/Utils.hs view
@@ -1,9 +1,67 @@+-- | "Utils" contains frequently used utility function, some parameters to "Runtime", and debugging functions.+-- | Utils should not import other modules of Penrose.++-- This is for the "typeclass synonym"+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_HADDOCK prune #-}+ module Utils where import Debug.Trace+import Data.Typeable+import Control.Arrow +default (Int, Float)++-- | A more concise typeclass for polymorphism for autodiff+-- | NiceFloating :: * -> Constraint+-- https://stackoverflow.com/questions/48631939/a-concise-way-to-factor-out-multiple-typeclasses-in-haskell/48631986#48631986+type Autofloat a = (RealFloat a, Floating a, Real a, Show a, Ord a)+type Autofloat' a = (RealFloat a, Floating a, Real a, Show a, Ord a, Typeable a)++type Pt2 a = (a, a)+type Property = String++--------------------------------------------------------------------------------+-- Errors in the system++-- | Errors from one of the Substance, Style, or Element compilers.+data CompilerError+ = SubstanceParse String -- ^ an error in Substance parsing+ | StyleParse String -- ^ an error in Style parsing+ | ElementParse String -- ^ an error in Element parsing+ | SubstanceTypecheck String -- ^ an error in Substance typechecking+ | PluginParse String -- ^ an error in plugin parsing + | PluginRun String -- ^ an error when running a plugin + | StyleTypecheck String -- ^ an error in Style typechecking + | ElementTypecheck String -- ^ an error in Element typechecking+ deriving (Show)++-- | Errors from the optimizer+data RuntimeError =+ RuntimeError String+ deriving (Show)+++--------------------------------------------------------------------------------+-- Parameters of the system++stepsPerSecond :: Int+stepsPerSecond = 100000++picWidth, picHeight :: Int+picWidth = 800+picHeight = 700++ptRadius :: Float+ptRadius = 4 -- The size of a point on canvas++defaultWeight :: Floating a => a+defaultWeight = 1++-- Debug flags+-- debug = True debug = False-debugLineSearch = False-debugObj = False -- turn on/off output in obj fn or constraint+debugStyle = False -- used when sampling the inital state, make sure sizes satisfy subset constraints subsetSizeDiff :: Floating a => a@@ -12,42 +70,123 @@ epsd :: Floating a => a -- to prevent 1/0 (infinity). put it in the denominator epsd = 10 ** (-10) +--------------------------------------------------------------------------------+-- General helper functions++fromRight :: (Show a, Show b) => Either a b -> b+fromRight (Left x) = error ("Failed with error: " ++ show x)+fromRight (Right y) = y++divLine :: IO ()+divLine = putStr "\n--------\n\n"++-- don't use r2f outside of zeroGrad or addGrad, since it doesn't interact well w/ autodiff+r2f :: (Fractional b, Real a) => a -> b+r2f = realToFrac++-- | Wrap a list around anything+toList :: a -> [a]+toList x = [x]++-- | similar to fst and snd, get the third element in a tuple+trd :: (a, b, c) -> c+trd (_, _, x) = x++-- | transform from a 2-element list to a 2-tuple+tuplify2 :: [a] -> (a,a)+tuplify2 [x,y] = (x,y)++-- | apply a function to each element of a 2-tuple+app2 :: (a -> b) -> (a, a) -> (b, b)+app2 f (x, y) = (f x, f y)++-- | apply a function to each element of a 3-tuple+app3 :: (a -> b) -> (a, a, a) -> (b, b, b)+app3 f (x, y, z) = (f x, f y, f z)++-- | generic cartesian product of elements in a list+cartesianProduct :: [[a]] -> [[a]]+cartesianProduct = foldr f [[]] where f l a = [ x:xs | x <- l, xs <- a ]++-- | given a side of a rectangle, compute the length of the half half diagonal halfDiagonal :: (Floating a) => a -> a halfDiagonal side = 0.5 * dist (0, 0) (side, side) +-- | `compose2` is used to compose with a function that takes in+-- two arguments. As if now, it is used to compose `penalty` with+-- constraint functions+compose2 :: (b -> c) -> (a -> a1 -> b) -> a -> a1 -> c+compose2 = (.) . (.)++concat4 :: [([a], [b], [c], [d])] -> ([a], [b], [c], [d])+concat4 x = (concatMap fst4 x, concatMap snd4 x, concatMap thd4 x, concatMap frth4 x)+fst4 (a, _, _, _) = a+snd4 (_, a, _, _) = a+thd4 (_, _, a, _) = a+frth4 (_, _, _, a) = a++-- | Define ternary expressions in Haskell+data Cond a = a :? a++infixl 0 ?+infixl 1 :?++(?) :: Bool -> Cond a -> a+True ? (x :? _) = x+False ? (_ :? y) = y++--------------------------------------------------------------------------------+-- Internal naming conventions++nameSep, labelWord :: String+nameSep = " "+labelWord = "label"+ labelName :: String -> String-labelName name = "Label_" ++ name+labelName name = name ++ nameSep ++ labelWord +-- | Given a Substance ID and a Style ID for one of its associated graphical primitive, generate a globally unique identifier for this primitive+uniqueShapeName :: String -> String -> String+uniqueShapeName subObjName styShapeName = subObjName ++ nameSep ++ styShapeName+ -- e.g. "B yaxis" (the concatenation should be unique), TODO add the two names as separate obj fields --- Some debugging functions. @@@+++++--------------------------------------------------------------------------------+-- Debug Functions++-- Some debugging functions. debugF :: (Show a) => a -> a debugF x = if debug then traceShowId x else x debugXY x1 x2 y1 y2 = if debug then trace (show x1 ++ " " ++ show x2 ++ " " ++ show y1 ++ " " ++ show y2 ++ "\n") else id -- To send output to a file, do ./EXECUTABLE 2> FILE.txt++-- For Runtime use only tr :: Show a => String -> a -> a tr s x = if debug then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order +-- For Style use only+trs :: Show a => String -> a -> a+trs s x = if debugStyle then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order+ trRaw :: Show a => String -> a -> a-trRaw s x = if debug then trace "---" $ trace s $ trace (show x ++ "\n") x else x-- prints in left to right order+trRaw s x = trace "---" $ trace s $ trace (show x ++ "\n") x -- prints in left to right order trStr :: String -> a -> a trStr s x = if debug then trace "---" $ trace s x else x -- prints in left to right order -tr' :: Show a => String -> a -> a-tr' s x = if debugLineSearch then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order--tro :: Show a => String -> a -> a-tro s x = if debugObj then trace "---" $ trace s $ traceShowId x else x -- prints in left to right order------ Lists-as-vectors utility functions, TODO split out of file+--------------------------------------------------------------------------------+-- Lists-as-vectors utility functions -- define operator precedence: higher precedence = evaluated earlier infixl 6 +., -.-infixl 7 *. -- .*, /.+infixl 7 *., /. -- assumes lists are of the same length-dotL :: Floating a => [a] -> [a] -> a+dotL :: (RealFloat a, Floating a) => [a] -> [a] -> a dotL u v = if not $ length u == length v then error $ "can't dot-prod different-len lists: " ++ (show $ length u) ++ " " ++ (show $ length v) else sum $ zipWith (*) u v@@ -68,8 +207,34 @@ (*.) :: Floating a => a -> [a] -> [a] -- multiply by a constant (*.) c v = map ((*) c) v +(/.) :: Floating a => [a] -> a -> [a]+(/.) v c = map ((/) c) v++p2v (x, y) = [x, y]++v2p [x, y] = (x, y)++infixl 6 +:, -:+infixl 7 *:, /:++(+:) :: Floating a => (a, a) -> (a, a) -> (a, a)+(+:) (x, y) (c, d) = (x + c, y + d)++(-:) :: Floating a => (a, a) -> (a, a) -> (a, a)+(-:) (x, y) (c, d) = (x - c, y - d)++(*:) :: Floating a => a -> (a, a) -> (a, a)+(*:) c (x, y) = (c * x, c * y)++(/:) :: Floating a => (a, a) -> a -> (a, a)+(/:) (x, y) c = (c / x, c / y)++dotv :: Floating a => (a, a) -> (a, a) -> a+dotv (x, y) (a, b) = x * a + y * b++-- Again (see below), we add epsd to avoid NaNs. This is a general problem with using `sqrt`. norm :: Floating a => [a] -> a-norm = sqrt . sum . map (^ 2)+norm v = sqrt ((sum $ map (^ 2) v) + epsd) normsq :: Floating a => [a] -> a normsq = sum . map (^ 2)@@ -84,8 +249,143 @@ midpoint :: Floating a => (a, a) -> (a, a) -> (a, a) -- mid point midpoint (x1, y1) (x2, y2) = ((x1 + x2) / 2, (y1 + y2) / 2) +midpointV :: Floating a => [a] -> [a] -> [a]+midpointV x y = (x +. y) /. 2.0++-- We add epsd to avoid NaNs in the denominator of the gradient of dist.+-- Now, grad dist (0, 0) (0, 0) is 0 instead of NaN. dist :: Floating a => (a, a) -> (a, a) -> a -- distance-dist (x1, y1) (x2, y2) = sqrt ((x1 - x2)^2 + (y1 - y2)^2)+dist (x1, y1) (x2, y2) = sqrt ((x1 - x2)^2 + (y1 - y2)^2 + epsd) distsq :: Floating a => (a, a) -> (a, a) -> a -- distance distsq (x1, y1) (x2, y2) = (x1 - x2)^2 + (y1 - y2)^2++-- Closest point on line segment to a point+-- https://stackoverflow.com/questions/849211/shortest-distance-between-a-point-and-a-line-segment+closestpt_pt_seg :: (Floating a, Ord a) => (a, a) -> ((a, a), (a, a)) -> (a, a)+closestpt_pt_seg p@(px, py) (v@(vx, vy), w@(wx, wy)) =+ let eps = 10 ** (-3)+ lensq = distsq v w in+ if lensq < eps then v -- line seg looks like a point+ else let dir = w -: v+ t = ((p -: v) `dotv` dir) / lensq -- project vector onto line seg and normalize+ t' = clamp (0, 1) t in+ v +: (t' *: dir) -- walk along vector of line seg++clamp :: (Floating a, Ord a) => (a, a) -> a -> a+clamp (l, r) x = max l $ min r x++--------------------------------------+-- Reflection capabilities to typecheck Computation functions+-- Typeable doesn't works with polymorphism (e.g. `id`) but works with `Floating a` by replacing it with `Double`+-- Adapted https://stackoverflow.com/questions/5144799/reflection-on-inputs-to-a-function-in-haskell+-- TODO unit test for function+-- Unfortunately it's pretty slow...++-- BTW, to check if something has the same type at runtime, can check equality of their typereps (or [Typerep], or [String], or String)+fnTypes :: Typeable a => a -> [TypeRep]+fnTypes x = split (typeOf x)+ where split t = case first tyConName (splitTyConApp t) of+ (_ , []) -> [t] -- not an arrow+ ("(->)", [x]) -> [x] -- return value type+ ("(->)", x) -> let current = init x+ next = last x+ in current ++ split next+ (_ , _) -> [t]++fnTypesStr :: Typeable a => a -> [String]+fnTypesStr = map show . fnTypes++-- If not an arrow type, then first list is empty (as expected)+inputsOutput :: Typeable a => a -> ([TypeRep], TypeRep)+inputsOutput x = let res = fnTypes x in+ (init res, last res)++inputsOutputStr :: Typeable a => a -> ([String], String)+inputsOutputStr x = let (args, val) = inputsOutput x in+ (map show args, show val)++-- other helpers++rot90 :: Floating a => (a, a) -> (a, a)+rot90 (x,y) = (-y,x)++lerpP :: Floating a => (a, a) -> (a, a) -> a -> (a, a)+lerpP (a,b) (c,d) k = let + lerpNum a b = a*(1.0-k) + b*k+ in (lerpNum a c, lerpNum b d)++mag :: Floating a => (a, a) -> a+mag (a,b) = sqrt $ magsq (a,b)++magsq :: Floating a => (a, a) -> a+magsq (a,b) = a**2 + b**2++normalize' :: Floating a => (a, a) -> (a, a)+normalize' (a,b) = let l = mag (a,b) in (a/l, b/l)++scaleP :: Floating a => a -> (a, a) -> (a, a)+scaleP k (a,b) = (a*k, b*k)++translate2 :: Floating a => (a, a) -> [(a, a)] -> [(a, a)]+translate2 v pts = map (+: v) pts++map2 :: (a -> b) -> (a, a) -> (b, b)+map2 f (a, b) = (f a, f b)++rotateList :: [a] -> [a]+rotateList l = take (length l) $ drop 1 (cycle l)++-- | Scale a value x in [lower, upper] linearly to x' lying in range [lower', upper'].+-- (Allow reverse lerping, i.e. upper < lower)+scaleLinear :: Autofloat a => a -> Pt2 a -> Pt2 a -> a+scaleLinear x (lower, upper) (lower', upper') = + if x < lower || x > upper + then trace ("invalid value " ++ show x ++ " to range " ++ show (lower, upper)) x+ -- Values may be wrong in the intermediate stage due to optimization, so maybe clamp to range anyway+ else let (range, range') = (upper - lower, upper' - lower')+ in ((x - lower) / range) * range' + lower'++-- n = number of interpolation points (not counting endpoints)+-- so with n = 1, we would have [x1, (x1+x2/2), x2]+lerp :: Autofloat a => a -> a -> Int -> [a]+lerp x1 x2 n = let dx = (x2 - x1) / (fromIntegral n + 1) in+ take (n + 2) $ iterate (+ dx) x1++lerp2 :: Autofloat a => Pt2 a -> Pt2 a -> Int -> [Pt2 a]+lerp2 (x1, y1) (x2, y2) n = let xs = lerp x1 x2 n + ys = lerp y1 y2 n+ in zip xs ys -- Interp both simultaneously+ -- Interp the first, then the second+ -- in zip xs (repeat y1) ++ zip (repeat x2) ys++cross :: Autofloat a => [a] -> [a] -> [a]+cross [x1, y1, z1] [x2, y2, z2] = [ y1 * z2 - y2 * z1,+ x2 * z1 - x1 * z2,+ x1 * y2 - x2 * y1 ]++angleBetweenRad :: Autofloat a => [a] -> [a] -> a -- Radians+angleBetweenRad p q = acos ((p `dotL` q) / (norm p * norm q + epsd))++-- n is the "original" plane normal for pq+-- https://stackoverflow.com/questions/5188561/signed-angle-between-two-3d-vectors-with-same-origin-within-the-same-plane+angleBetweenSigned :: Autofloat a => [a] -> [a] -> [a] -> a -- Radians+angleBetweenSigned n p q = let sign = -1 * signum ((p `cross` q) `dotL` n) in+ sign * angleBetweenRad p q++-- Unit rotation in the plane of the basis vectors (e1, e2) to time t (arc length)+-- Used for spherical geometry.+-- NOTE: expects e1 and e2 to be unit vectors+circPtInPlane :: Autofloat a => [a] -> [a] -> a -> [a]+circPtInPlane e1 e2 t = cos t *. e1 +. sin t *. e2++-- Assuming unit circle and unit basis vectors. Arc starts at e1.+slerp :: Autofloat a => Int -> a -> a -> [a] -> [a] -> [[a]]+slerp n t0 t1 e1 e2 = let dt = (t1 - t0) / (fromIntegral n + 1)+ ts = take (n + 2) $ iterate (+ dt) t0+ in map (circPtInPlane e1 e2) ts -- Travel along the arc++-- Project q onto p, without normalization+proj :: Autofloat a => [a] -> [a] -> [a]+proj p q = let unit_p = normalize p+ in (q `dotL` unit_p) *. unit_p
+ test/Functions/Tests.hs view
@@ -0,0 +1,41 @@+module Functions.Tests (tests) where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Debug.Trace+import Data.Fixed++import Functions+import Shapes+import Utils++tests :: TestTree+tests = testGroup "Functions tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]++++group1 :: TestTree+group1 = testGroup "Group"+ [ + ]++--------++scProps = testGroup "(checked by SmallCheck)" + [ + ]++qcProps = testGroup "(checked by QuickCheck)" + [ + ]++-- Module: topic: function: property+unitTests :: TestTree+unitTests = testGroup "Unit tests" + [ group1+ ]
+ test/Server/Tests.hs view
@@ -0,0 +1,27 @@+module Server.Tests (tests) where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import Server++tests :: TestTree+tests = testGroup "Server tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]++scProps = testGroup "(checked by SmallCheck)" + [ + ]++qcProps = testGroup "(checked by QuickCheck)" + [ + ]++-- Module: topic: function: property+unitTests = testGroup "Unit tests" + [ + ]
+ test/ShadowMain/Tests.hs view
@@ -0,0 +1,75 @@+module ShadowMain.Tests (tests) where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import System.IO.Unsafe (unsafePerformIO)+import ShadowMain+import Shapes+import Debug.Trace++tests :: TestTree+tests = testGroup "ShadowMain tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]++------------------------------- Utils++failed :: Assertion+failed = False @?= True++-- type V2 = (Float, Float)+-- type TestInfo = (String, String, String, String, [Obj], [Obj])++-- TODO: For final state, only check location equality because label sizes depend on renderer (e.g. snap)+-- locs :: [Obj] -> [V2]+-- locs = map (\o -> (getX o, getY o))++-- Given a test name, Substance file, Style file, and ground truth initial and final states,+-- generates two unit tests: one for the initial states and one for the final states.+-- TODO: tests depend on hardcoded parameters in Runtime: initRng (random seed) and choice of initial state+-- TODO: port mainRetInit and mainRetFinal+-- genTests :: TestInfo -> [TestTree]+-- genTests (testName, subName, styName, dsllName, initTruth, finalTruth) =+ -- []++ -- let nameInit = testName ++ ": init state" in+ -- let nameFinal = testName ++ ": final state" in+ -- let initState = unsafePerformIO $ mainRetInit subName styName dsllName in+ -- let (aInit, aFinal) = case initState of+ -- Nothing -> (failed, failed)+ -- Just init -> let testInit = (objs init == initTruth) @?= True in+ -- let final = mainRetFinal init in+ -- let testFinal = trace ("final objs: " ++ (show $ objs final)) $+ -- ((locs $ objs final) == locs finalTruth) @?= True in+ -- (testInit, testFinal) in+ -- [testCase nameInit aInit, testCase nameFinal aFinal]++unitTests = testGroup "Unit tests" []++scProps = testGroup "(checked by SmallCheck)" []++qcProps = testGroup "(checked by QuickCheck)" []++-----------------------------+-- Regression tests based on examples+-- To add a test, add a new t :: TestInfo, and add t to the all_test_info list.+-- TODO: add ability to read from file++{-+twopoints_computed :: TestInfo+twopoints_computed = ("two points, one computed",+ "src/sub/twopoints.sub", "src/sty/twopoints.sty",+ "src/dsll/setTheory.dsl",+ [L (Label {xl = -175.52109, yl = 324.19635, wl = 0.0, hl = 0.0, textl = "a", sell = False, namel = "Label_a"}),L (Label {xl = 256.43604, yl = 219.0672, wl = 0.0, hl = 0.0, textl = "b", sell = False, namel = "Label_b"}),P (Pt {xp = 9.113647, yp = -13.938477, selp = False, namep = "a"}),P (Pt {xp = 109.11365, yp = 186.06152, selp = False, namep = "b"})],+ [L (Label {xl = 9.966248, yl = 20.311262, wl = 6.65625, hl = 16.359375, textl = "a", sell = False, namel = "Label_a"}),L (Label {xl = 109.96625, yl = 220.31126, wl = 6.9375, hl = 16.359375, textl = "b", sell = False, namel = "Label_b"}),P (Pt {xp = -3.0389898e-2, yp = 0.25816754, selp = False, namep = "a"}),P (Pt {xp = 99.96961, yp = 200.25816, selp = False, namep = "b"})])+-}++-- all_test_info :: [TestInfo]+-- all_test_info = [+ -- FIXME: commented out because the tests no longer pass+ -- twopoints_computed, venn_subset, tree_subset+ -- ]
+ test/Shapes/Tests.hs view
@@ -0,0 +1,38 @@+module Shapes.Tests (tests) where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import Shapes+import System.Random++tests :: TestTree+tests = testGroup "Shapes tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]++gen :: StdGen+gen = mkStdGen seed+ where seed = 16 -- deterministic RNG with seed++circ_get_set_id :: Assertion+circ_get_set_id = let (cir, g) = defaultShapeOf gen circType in+ let x = 10.0 in+ let res = getX $ setX (FloatV x) cir in+ (res == x) @?= True+ +scProps = testGroup "(checked by SmallCheck)" + [ + ]++qcProps = testGroup "(checked by QuickCheck)" + [ + ]++-- Module: topic: function: property+unitTests = testGroup "Unit tests" + [ testCase "one kind of object, get/set identity" circ_get_set_id+ ]
+ test/TestSuite.hs view
@@ -0,0 +1,38 @@+-- Modeled after Snap: https://github.com/snapframework/snap-core/blob/master/test/TestSuite.hs+module Main where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++-- TODO factor out test into functions+-- TODO check/track test coverage+-- TODO figure out how to test ShadowMain and optimization intermediate stages+-- TODO use template haskell / test discovery+-- TODO we might want inline assertions in code too, to enforce invariants++-- import Main hiding (main)+import qualified ShadowMain.Tests+import qualified Functions.Tests+import qualified Shapes.Tests+import qualified Utils.Tests+import qualified Transforms.Tests+-- import qualified Substance.Tests+-- import qualified Style.Tests+import qualified Server.Tests++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests"+ [ ShadowMain.Tests.tests,+ Functions.Tests.tests,+ Shapes.Tests.tests,+ Utils.Tests.tests,+ Transforms.Tests.tests,+ -- NOTE: need better test cases since we cannot parse Substance nor Style progs without element progs+ -- Substance.Tests.tests,+ -- Style.Tests.tests,+ Server.Tests.tests+ ]
+ test/Transforms/Tests.hs view
@@ -0,0 +1,131 @@+module Transforms.Tests (tests) where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Debug.Trace+import Data.Fixed++import Utils+import Transforms+import Functions+import Shapes++tests :: TestTree+tests = testGroup "Functions tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]+++eps :: Float+eps = 10 ** (-3) -- Kind of arbitrarily picked so the tests pass. Not sure about the right precision++hmEq :: HMatrix Float -> HMatrix Float -> Bool+hmEq t1 t2 = hmDiff t1 t2 <= eps++ptsEq :: Pt2 Float -> Pt2 Float -> Bool+ptsEq (x1, y1) (x2, y2) = sqrt ((x1 - x2)^2 + (y1 - y2)^2) < eps -- Should use a different eps++id_compose_id :: Assertion+id_compose_id = idH # idH @?= idH++rotate_2pi_id :: Assertion+rotate_2pi_id = hmEq idH (rotationM (2 * pi)) @?= True++rotate_rev :: Float -> Bool+rotate_rev radians = hmEq idH (rotationM radians # rotationM (-radians)) == True++rotate_twice :: Float -> Bool+rotate_twice radians = hmEq (rotationM (2 * radians)) (rotationM radians # rotationM (radians)) + == True++translate_id :: Float -> Float -> Bool+translate_id x y = hmEq idH (translationM (x, y) # translationM (-x, -y)) == True++scale_id :: Float -> Float -> Bool+scale_id cx cy = let res = (scalingM (1/cx, 1/cy) # scalingM (cx, cy)) in+ if cx /= 0.0 && cy /= 0.0 then+ hmEq idH res == True+ else True -- Ignore scaling by 0++id_mul :: (Float, Float, Float, Float, Float, Float) -> Bool+id_mul (x1, x2, x3, x4, x5, x6) = let m = listToHm [x1, x2, x3, x4, x5, x6] in+ hmEq (idH # m) (m # idH) && hmEq (m # idH) m++-- Not true in general+rot_tr :: Float -> Bool+rot_tr x = if x == 0.0 then True + else ptsEq ((rotationM (pi/2) # translationM (x, 0)) ## (0, 0)) + (translationM (0, x) ## (0, 0)) == True++trs1 :: Assertion+trs1 = ptsEq ((translationM (-1, 1) # rotationM (pi/2) # scalingM (2, 1)) ## (1, 0))+ (-1,3.0) @?= True++-- Starting with some parameters, we show we can extract the same (?) parameters from the composed matrix+-- It's lossy though, so some tests might fail when the angle can't be reconstructed+params_matrix_id' :: (Float, Float, Float, Float, Float) -> Bool+params_matrix_id' p@(sx, sy, theta, dx, dy) =+ let p0 = [sx, sy, theta `mod'` (2.0 * pi), dx, dy]+ -- might not work with theta out of range [-2pi, 2pi]+ m = paramsToMatrix p+ (sx', sy', theta', dx', dy') = paramsOf m + p' = [sx', sy', theta', dx', dy']+ in if sx < eps || sy < eps then True -- don't scale by 0+ else norm (p0 -. p') < eps++-- This also can't test it fully though, for example if the matrix didn't result from +-- the canonical scale-then-rotate-then-translate+-- e.g. if it consists only of a shear: m = listToHm [1.0,0.0,0.0,1.0,1.0,0.0]+params_matrix_eq :: (Float, Float, Float, Float, Float, Float) -> Bool+params_matrix_eq (x1, x2, x3, x4, x5, x6) = let m = listToHm [x1, x2, x3, x4, x5, x6] in+ if x1 < eps || x5 < eps then True -- don't scale by 0+ else hmEq m (paramsToMatrix $ paramsOf m)++-- TODO+-- do we need any checks for numerical stability?+-- test the canonical order: scale(w, h) then rotate(theta) then translate(x, y) = ???+-- test skewing+-- test things that commute+-- test things that don't commute++transformsGroup :: TestTree+transformsGroup = testGroup "Transforms"+ [ testCase "idH * idH = idH" id_compose_id,+ testCase "rotate by 2pi = idH" rotate_2pi_id,+ testCase "translate, rotate, scale example" trs1+ ]++--------++scProps = testGroup "(checked by SmallCheck)" + [ + ]++qcProps = testGroup "(checked by QuickCheck)" + [ QC.testProperty "forall x, rotate(x) . rotate (-x) = idH" rotate_rev,+ QC.testProperty "rotate t * rotate -t = id" rotate_rev,+ QC.testProperty "rotate 2t = rotate t * rotate t" rotate_twice,+ QC.testProperty "translate v * translate -v = idH" translate_id,+ QC.testProperty "scale (cx,cy) * scale (-cx, -cy) = idH" scale_id,+ QC.testProperty "id * A = A * id = A" id_mul++ -- This test isn't true in general+ -- QC.testProperty "translate then rotate CCW can equal a translation up" rot_tr++ -- TODO: These tests don't pass reliably, because starting with base DOF, converting them to a matrix, and trying to solve for the original params does not have a unique solution+ -- (i.e. might find satisfying params that are not the original params).+ -- Although I'm not sure why the second test isn't passing. Perhaps floating-point equality checks?+ -- Anyway, we don't actually solve for any of the original DOF in the Penrose systems, so I'm commenting these tests out. (-kye)++ -- QC.testProperty "(params -> matrix -> solve for params) ~ params" params_matrix_id',+ -- QC.testProperty "matrix ~ (matrix -> params -> matrix)" params_matrix_eq+ ]++-- Module: topic: function: property+unitTests :: TestTree+unitTests = testGroup "Unit tests" + [ transformsGroup+ ]
+ test/Utils/Tests.hs view
@@ -0,0 +1,34 @@+module Utils.Tests (tests) where++import Test.Tasty+import Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import Utils++tests :: TestTree+tests = testGroup "Utils tests" [properties, unitTests]++properties :: TestTree+properties = testGroup "Properties" [scProps, qcProps]++distNonnegative :: Float -> Float -> Float -> Float -> Bool+distNonnegative x1 y1 x2 y2 = dist (x1, y1) (x2, y2) >= 0++-- this is actually 1e-5+distNonNaN_atZero :: Assertion+distNonNaN_atZero = isNaN (dist (0, 0) (0, 0)) @?= False++scProps = testGroup "(checked by SmallCheck)" -- use SC.testProperty+ [ + ]++qcProps = testGroup "(checked by QuickCheck)" + [ QC.testProperty "dist: distance always non-negative" distNonnegative+ ]++-- Module: topic: function: property+unitTests = testGroup "Unit tests" + [ testCase "autodiff: dist: no NaN" distNonNaN_atZero+ ]