<commit_before>module ShapeDef where

import Utils
import qualified Data.Map.Strict as M

--------------------------------------------------------------------------------
-- Types

-- | types of fully evaluated values in Style
data ValueType
    = FloatT
    | IntT
    | BoolT
    | StrT
    | PtT
    | PathT
    | ColorT
    | FileT
    | StyleT
    deriving (Eq, Show)

-- | fully evaluated values in Style
data Value a
    -- | Floating point number
    = FloatV a
    -- | integer
    | IntV Integer
    -- | boolean value
    | BoolV Bool
    -- | string literal
    | StrV String
    -- | point in R^2
    | PtV (Pt2 a)
    -- | a list of points
    | PathV [Pt2 a]
    -- | an RGBA color value
    | ColorV Color
    -- | path for image
    | FileV String
    -- | dotted, etc.
    | StyleV String
    -- COMBAK: decide whether GPIs or shortcuts to multiple GPIs should be vals
    -- -- | Substance ID
    -- | TAllShapes String
    -- -- | shape ID
    -- | TShape String
    deriving (Eq, Show)

-- | the type string of a shape
type ShapeType = String
-- | the string identifier of a property
type PropID = String

-- | A dict storing names, types, and default values of properties
type PropertiesDef a = M.Map PropID (ValueType, Value a)
-- | definition of a new shape/graphical primitive
type ShapeDef a = (String, PropertiesDef a)
type ShapeDefs a = M.Map String (PropertiesDef a)

-- | A dictionary storing properties of a Style object, e.g. "start" for 'Arrow'
-- COMBAK: serializer to JSON
type Properties a = M.Map PropID (Value a)
-- | definition of a new shape/graphical primitive
type Shape a = (String, Properties a)

--------------------------------------------------------------------------------
-- Example shape defs

shapeDefs :: (Autofloat a) => ShapeDefs a
shapeDefs = M.fromList defList
    where defList = [circType]

circType, arrowType, curveType :: (Autofloat a) => ShapeDef a
circType = ("Circle", M.fromList
    [
        ("x", (FloatT, FloatV 0.0)),
        ("y", (FloatT, FloatV 0.0)),
        ("stroke", (FloatT, FloatV 0.0)),
        ("name", (StrT, StrV "defaultCircle")),
        ("style", (StrT, StrV "filled")),
        ("color", (ColorT, ColorV black))
    ])
arrowType = ("Arrow", M.fromList
    [
        ("startx", (FloatT, FloatV 0.0)),
        ("starty", (FloatT, FloatV 0.0)),
        ("endx", (FloatT, FloatV 0.0)),
        ("endy", (FloatT, FloatV 0.0)),
        ("name", (StrT, StrV "defaultArrow")),
        ("style", (StrT, StrV "straight")),
        ("color", (ColorT, ColorV black))
    ])
curveType = ("Curve", M.fromList
    [
        ("path", (PathT, PathV [])),
        ("name", (StrT, StrV "defaultCurve")),
        ("style", (StrT, StrV "solid")),
        ("color", (ColorT, ColorV black))
    ])


exampleCirc :: (Autofloat a) => Shape a
exampleCirc = ("Circ", M.fromList
    [
        ("x", FloatV 5.5),
        ("y", FloatV 100.2),
        ("name", StrV "C1"),
        ("color", ColorV black)
    ])

--------------------------------------------------------------------------------
-- Parser for shape def DSL (TODO)

--------------------------------------------------------------------------------
-- Type checker for a particular shape instance again its def (TODO)

-- checkShape :: (Autofloat a) => Shape a -> ShapeDef a -> Shape a
-- checkShape shape def =

--------------------------------------------------------------------------------
-- Utility functions for Runtime
-- * set
-- * get

-- 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 (n, propDict) prop val = case M.lookup prop propDict of
    Nothing -> error ("set: Property \"" ++ prop ++
                    "\" does not exist in shape \"" ++ n)
    _       -> (n, M.update (const $ Just val) prop propDict)

-- | Getting the value of a property
get :: (Autofloat a) => Shape a -> PropID -> Value a
get (n, propDict) prop = case M.lookup prop propDict of
    Nothing -> error ("get: Property \"" ++ prop ++
                    "\" does not exist in shape \"" ++ n)
    Just v  -> v

--------------------------------------------------------------------------------
-- Utility functions for objective/constraint function writers

-- | 'is' checks whether a shape is of a certain type
is :: (Autofloat a) => Shape a -> ShapeType -> Bool
is (t1, _) t2 = t1 == t2

--------------------------------------------------------------------------------
-- 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)

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

--------------------------------------------------------------------------------
-- DEBUG: main function to test out the module

main :: IO ()
main = putStrLn "Hello"<commit_msg>[shape-def] utility functions for Runtime and Functions<commit_after>module ShapeDef where

import Utils
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as M

--------------------------------------------------------------------------------
-- Types

-- | types of fully evaluated values in Style
data ValueType
    = FloatT
    | IntT
    | BoolT
    | StrT
    | PtT
    | PathT
    | ColorT
    | FileT
    | StyleT
    deriving (Eq, Show)

-- | fully evaluated values in Style
data Value a
    -- | Floating point number
    = FloatV a
    -- | integer
    | IntV Integer
    -- | boolean value
    | BoolV Bool
    -- | string literal
    | StrV String
    -- | point in R^2
    | PtV (Pt2 a)
    -- | a list of points
    | PathV [Pt2 a]
    -- | an RGBA color value
    | ColorV Color
    -- | path for image
    | FileV String
    -- | dotted, etc.
    | StyleV String
    -- COMBAK: decide whether GPIs or shortcuts to multiple GPIs should be vals
    -- -- | Substance ID
    -- | TAllShapes String
    -- -- | shape ID
    -- | TShape String
    deriving (Eq, Show)

-- | the type string of a shape
type ShapeType = String
-- | the string identifier of a property
type PropID = String

-- | A dict storing names, types, and default values of properties
type PropertiesDef a = M.Map PropID (ValueType, Value a)
-- | definition of a new shape/graphical primitive
-- TODO: rewrite as a record?
type ShapeDef a = (ShapeType, PropertiesDef a)

type ShapeDefs a = M.Map ShapeType (ShapeDef a)

-- | A dictionary storing properties of a Style object, e.g. "start" for 'Arrow'
-- TODO: (?) Maybe shouldn't be just value, but something like FieldExpr
-- data FieldExpr a = FExpr (TagExpr a)
--                  | GPI GPICtor (PropertyDict a)
-- 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 = (ShapeType, Properties a)

--------------------------------------------------------------------------------
-- Example shape defs

shapeDefs :: (Autofloat a) => ShapeDefs a
shapeDefs = M.fromList $ zipWithKey defList
    where defList = [circType]
          zipWithKey = map (\x -> (fst x, x))

findDef :: (Autofloat a) => ShapeType -> ShapeDefs a -> ShapeDef a
findDef typ defs = fromMaybe
    (noShapeError "findDef" typ)
    (M.lookup typ defs)

defaultValueOf :: (Autofloat a) => PropID -> ShapeDef a -> Value a
defaultValueOf prop (t, propDict) = snd $ fromMaybe
    (noPropError "defaultValueOf" prop t)
    (M.lookup prop propDict)

-- | TODO: derived properties
-- | TODO: instantiation of objs with (1) default values; (2) random sampling w.r.t. constraints
constructShape :: ShapeDef a -> [SampleRule] -> Shape a

circType, arrowType, curveType :: (Autofloat a) => ShapeDef a
circType = ("Circle", M.fromList
    [
        ("x", (FloatT, FloatV 0.0)),
        ("y", (FloatT, FloatV 0.0)),
        ("r", (FloatT, FloatV 0.0)),
        ("stroke", (FloatT, FloatV 0.0)),
        ("name", (StrT, StrV "defaultCircle")),
        ("style", (StrT, StrV "filled")),
        ("color", (ColorT, ColorV black))
    ])
arrowType = ("Arrow", M.fromList
    [
        ("startx", (FloatT, FloatV 0.0)),
        ("starty", (FloatT, FloatV 0.0)),
        ("endx", (FloatT, FloatV 0.0)),
        ("endy", (FloatT, FloatV 0.0)),
        ("name", (StrT, StrV "defaultArrow")),
        ("style", (StrT, StrV "straight")),
        ("color", (ColorT, ColorV black))
    ])
curveType = ("Curve", M.fromList
    [
        ("path", (PathT, PathV [])),
        ("name", (StrT, StrV "defaultCurve")),
        ("style", (StrT, StrV "solid")),
        ("color", (ColorT, ColorV black))
    ])


exampleCirc :: (Autofloat a) => Shape a
exampleCirc = ("Circle", M.fromList
    [
        ("x", FloatV 5.5),
        ("y", FloatV 100.2),
        ("r", FloatV 5),
        ("name", StrV "C1"),
        ("style", StyleV "filled"),
        ("color", ColorV black)
    ])

--------------------------------------------------------------------------------
-- Parser for shape def DSL (TODO)

--------------------------------------------------------------------------------
-- Type checker for a particular shape instance again 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

-- 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)

-- | 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
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
typeOf :: (Autofloat a) => PropID -> ShapeDef a -> ValueType
typeOf prop (t, propDict) = case M.lookup prop propDict of
    Nothing -> noPropError "typeOf" prop t
    Just (t, _)  -> t

-- | keys in alphabetical order
-- | vals in alphabetical order of their keys

--------------------------------------------------------------------------------
-- Utility functions for objective/constraint function writers

-- | 'is' checks whether a shape is of a certain type
is :: (Autofloat a) => Shape a -> ShapeType -> Bool
is (t1, _) t2 = t1 == t2

-- | short-hand for 'get'
(.:) :: (Autofloat a) => Shape a -> PropID -> Value a
(.:) = get

-- | ternary op for set (TODO: maybe later)
-- https://wiki.haskell.org/Ternary_operator

-- | Given ValueType and ShapeType, return all props of that ValueType
-- TODO: props -> properties
propsWithType :: (Autofloat a) =>
    ValueType -> ShapeType -> ShapeDefs a -> [PropID]
propsWithType propType shapeType defs =
    M.keys $ M.filter (\(t, _) -> t == propType) $ snd $ findDef shapeType defs

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


--------------------------------------------------------------------------------
-- 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)

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

--------------------------------------------------------------------------------
-- 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 $ propsWithType FloatT "Circle" shapeDefs
{'fraction_non_alphanumeric': 0.2122561215136834, 'fraction_numerical': 0.010540788267644362, 'mean_word_length': 1.8615586361933307, 'pattern_counts': {'":': 2, '<': 3, '<?xml version=': 0, '>': 101, 'https://': 3, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1017160', 'n_tokens_mistral': 4737, 'n_tokens_neox': 4543, 'n_words': 1693}