Done deprecating gloss #10 #31

penrose · Jun 12, 2018 · a168986 · a168986
1 parent 01f23e3
commit a168986
Show file tree

Hide file tree

Showing 6 changed files with 61 additions and 37 deletions.
diff --git a/penrose.cabal b/penrose.cabal
@@ -29,7 +29,6 @@ executable penrose
                        random              >= 1.1 && <1.2,
                        random-shuffle      >= 0.0.4 && < 0.1,
                        containers          >= 0.5 && <0.6,
-                       gloss               >= 1.11 && <1.12,
                        megaparsec          >= 6.2 && < 6.5,
                        ad                  >= 4.3 && <4.4,
                        aeson               >= 1.2 && <1.3,
@@ -56,7 +55,6 @@ Test-Suite penrose-testsuite
                        random              >= 1.1 && <1.2,
                        random-shuffle      >= 0.0.4 && < 0.1,
                        containers          >= 0.5 && <0.6,
-                       gloss               >= 1.11 && <1.12,
                        megaparsec          >= 6.4 && < 6.5,
                        ad                  >= 4.3 && <4.4,
                        aeson               >= 1.2 && <1.3,

diff --git a/src/Computation.hs b/src/Computation.hs
@@ -5,7 +5,6 @@ import Shapes
 import Utils
 import Functions
 import qualified Data.Map.Strict as M
-import Graphics.Gloss.Interface.Pure.Game
 import Debug.Trace
 import System.Random
 import System.Random.Shuffle
@@ -80,12 +79,12 @@ computeSurjection g numPoints (lowerx, lowery) (topx, topy) =
 -- Points generated lie in the bbox given, whether in math space or screen space
 -- TODO pass randomness around in Runtime
 computeBijection :: Autofloat a => StdGen -> Integer -> Pt2 a -> Pt2 a -> ([Pt2 a], StdGen)
-computeBijection g numPoints (lowerx, lowery) (topx, topy) = 
-                  if numPoints < 2 then error "Bijection needs to have >= 2 points" 
+computeBijection g numPoints (lowerx, lowery) (topx, topy) =
+                  if numPoints < 2 then error "Bijection 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_plot = nub (reverse (sort xs))
-                           (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f lowery, r2f topy) 
+                           (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f lowery, r2f topy)
                            ys = lowery : ys_inner ++ [topy] --clude endpts so function is onto
                            ys_plot = (nub (sort ys)) in -- Random permutation. TODO return g3?
                            (zip xs_plot ys_plot, g'') -- len xs == len ys
@@ -95,12 +94,12 @@ computeBijection g numPoints (lowerx, lowery) (topx, topy) =
 -- Points generated lie in the bbox given, whether in math space or screen space
 -- TODO pass randomness around in Runtime
 computeInjection :: Autofloat a => StdGen -> Integer -> Pt2 a -> Pt2 a -> ([Pt2 a], StdGen)
-computeInjection g numPoints (lowerx, lowery) (topx, topy) = 
-                  if numPoints < 2 then error "Injection needs to have >= 2 points" 
+computeInjection g numPoints (lowerx, lowery) (topx, topy) =
+                  if numPoints < 2 then error "Injection 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_plot = nub (reverse (sort xs))
-                           (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f (lowery + (topy - lowery)/4), r2f (topy - (topy - lowery)/4)) 
+                           (ys_inner, g'') = randomsIn g' (numPoints - 2) (r2f (lowery + (topy - lowery)/4), r2f (topy - (topy - lowery)/4))
                            ys = (lowery + (topy - lowery)/4) : ys_inner ++ [topy - (topy - lowery)/4] --clude endpts so function is onto
                            ys_plot = (nub (sort ys)) in -- Random permutation. TODO return g3?
                            (zip xs_plot ys_plot, g'') -- len xs == len ys
@@ -128,22 +127,22 @@ computeSurjectionLines g n left right bottom top =
                        computeSurjection g n lower_left top_right
 
 
--- Computes the bijection 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. 
+-- Computes the bijection 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.
-computeBijectionLines :: (Autofloat a) => StdGen -> Integer 
+computeBijectionLines :: (Autofloat a) => StdGen -> Integer
                                    -> Line' a -> Line' a -> Line' a -> Line' a -> ([Pt2 a], StdGen)
-computeBijectionLines g n left right bottom top = 
+computeBijectionLines g n left right bottom top =
                        let lower_left = (startx_l' left, starty_l' bottom) in
                        let top_right = (startx_l' right, starty_l' top) in
                        computeBijection g n lower_left top_right
 
--- Computes the injection 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. 
+-- Computes the injection 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.
-computeInjectionLines :: (Autofloat a) => StdGen -> Integer 
+computeInjectionLines :: (Autofloat a) => StdGen -> Integer
                                    -> Line' a -> Line' a -> Line' a -> Line' a -> ([Pt2 a], StdGen)
-computeInjectionLines g n left right bottom top = 
+computeInjectionLines g n left right bottom top =
                        let lower_left = (startx_l' left, starty_l' bottom) in
                        let top_right = (startx_l' right, starty_l' top) in
                        computeInjection g n lower_left top_right
@@ -267,12 +266,12 @@ computeSurjectionLines' [TNum x] [LN' l1, LN' l2, LN' l3, LN' l4] =
 computeSurjectionLines' v o = error' "computeSurjectionLines" v o
 
 computeBijectionLines' :: CompFn a
-computeBijectionLines' [TNum x] [LN' l1, LN' l2, LN' l3, LN' l4] = 
+computeBijectionLines' [TNum x] [LN' l1, LN' l2, LN' l3, LN' l4] =
                         TPath $ fst $ computeBijectionLines compRng (floor x) l1 l2 l3 l4
 computeBijectionLines' v o = error' "computeBijectionLines" v o
 
 computeInjectionLines' :: CompFn a
-computeInjectionLines' [TNum x] [LN' l1, LN' l2, LN' l3, LN' l4] = 
+computeInjectionLines' [TNum x] [LN' l1, LN' l2, LN' l3, LN' l4] =
                         TPath $ fst $ computeInjectionLines compRng (floor x) l1 l2 l3 l4
 computeInjectionLines' v o = error' "computeInjectionLines" v o
 

diff --git a/src/Runtime.hs b/src/Runtime.hs
@@ -19,7 +19,6 @@ import Data.Maybe
 import Data.Monoid ((<>))
 import Data.Aeson
 import Data.Function
-import Graphics.Gloss.Data.Color -- TODO: remove this dependency
 import Numeric.AD
 import GHC.Float -- float <-> double conversions
 import System.IO

diff --git a/src/ShadowMain.hs b/src/ShadowMain.hs
@@ -2,9 +2,6 @@
 
 module ShadowMain where
 import Utils
-import Graphics.Gloss
-import Graphics.Gloss.Data.Vector
-import Graphics.Gloss.Interface.Pure.Game
 import qualified Server
 import qualified Runtime as R
 import qualified Substance as C
@@ -25,8 +22,8 @@ shadowMain = do
     -- 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 /= 4) $ die "Usage: ./Main <snap|gloss> prog1.sub prog2.sty prog3.dsl"
-    let (mode, subFile, styFile, dsllFile) = (head args, args !! 1, args !! 2, args !! 3)
+    when (length args /= 3) $ die "Usage: ./Main prog1.sub prog2.sty prog3.dsl"
+    let (subFile, styFile, dsllFile) = (head args, args !! 1, args !! 2)
     subIn  <- readFile subFile
     styIn  <- readFile styFile
     dsllIn <- readFile dsllFile
@@ -84,16 +81,14 @@ shadowMain = do
             divLine
             putStrLn "Visualizing Substance program:\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
+            -- Starting serving penrose on the web
+            let (domain, port) = ("127.0.0.1", 9160) 
+            Server.servePenrose domain port initState
 
-                else error "only snap is supported as a frontend\n"
 
 -- Versions of main for the tests to use that takes arguments internally, and returns initial and final state
 -- (extracted via unsafePerformIO)
--- Very similar to shadowMain but does not depend on rendering (snap/gloss) so it does not return SVG
+-- Very similar to shadowMain but does not depend on rendering  so it does not return SVG
 -- TODO take initRng seed as argument
 mainRetInit :: String -> String -> String -> IO (Maybe R.State)
 mainRetInit subFile styFile dsllFile = do

diff --git a/src/Shapes.hs b/src/Shapes.hs
@@ -3,7 +3,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DuplicateRecordFields #-}
+-- {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 
@@ -12,7 +12,6 @@ module Shapes where
 import Data.Aeson
 import Data.Monoid ((<>))
 import GHC.Generics
-import Graphics.Gloss
 import Data.Data
 import Data.Typeable
 import Utils
@@ -29,6 +28,7 @@ class Named a where
       getName :: a -> Name
       setName :: Name -> a -> a
 
+
 -------
 data CubicBezier = CubicBezier {
     pathcb           :: [(Float, Float)],
@@ -686,7 +686,7 @@ data TypeIn a = TNum a
               -- | shape ID, property of that shape
               | TProp String Property
               -- | a call to computation function
-              | TCall String [TypeIn a] 
+              | TCall String [TypeIn a]
      deriving (Eq, Show, Data, Typeable)
 
 -- TODO: should we collect the types that need computation to another single type. For example:
@@ -862,3 +862,39 @@ set "location" (L' o) (TPt (x, y)) = L' $ o { xl' = x, yl' = y }
 
 set prop obj val = error ("setting property/object/value combination not supported: \n" ++ prop ++ "\n"
                                    ++ show obj ++ "\n" ++ show val)
+
+
+--------------------------------------------------------------------------------
+-- 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, Data, Typeable)
+
+-- | 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
diff --git a/test/ShadowMain/Tests.hs b/test/ShadowMain/Tests.hs
@@ -10,8 +10,6 @@ import ShadowMain
 import Shapes
 import Runtime
 import Debug.Trace
-import Graphics.Gloss.Interface.Pure.Game
--- import Graphics.Gloss.Internals.Data.Color
 
 tests :: TestTree
 tests = testGroup "ShadowMain tests" [properties, unitTests]
@@ -24,7 +22,6 @@ properties = testGroup "Properties" [scProps, qcProps]
 failed :: Assertion
 failed = False @?= True
 
--- TODO: remove gloss dependency for Point and Color/RGBA/makeColor
 type V2 = (Float, Float)
 type TestInfo = (String, String, String, String, [Obj], [Obj])