import Html
import Html.App as App
import Html.Events
import Svg
import Svg.Attributes exposing (..)
import String
import Svg exposing (Attribute)
import Array
import Mouse exposing (Position)
import Json.Decode as Json exposing (..)
import Time exposing(..)
import Task
import Dict
import Char
-- don't worry about this, this type wraps up information needed for making games and animation
type Message = GameTick Float GetKeyState --The tick needs to have Float and GetKeyState which handles key presses.
-- this is the main function, and for simple animations, you would only replace the view function, or edit it below
main = gameApp GameTick {
model = model
, view = view
, update = update
}
-- this means that we only keep track of time, don't edit it
model = {
t = 0
}
-- the update would handle actions in a game or presentation which are more than a simple function of time
-- to start off, don't change anything!
update message model =
case message of
GameTick tick (getKeyState,changeP1,changeP2) -> {
t = tick
}
-- this view function draws your picture on the screen, you can draw whatever you want
-- if it depends on model.t, then it will move, otherwise it will not move
view model = collage 600 600 [
heart |> scale ((abs (sin model.t)) + 1)
]
-- to organize your picture/animation, you can define components of the scene and give them names, like "heart"
heart = group [ circle 40 |> filled red |> move (20,0)
, circle 40 |> filled red |> move (-20,0)
, ngon 4 40 |> filled red |> move (0,-35)
]
-- mystery: what are these for?
default = group [
outlined (solid 5) black (openPolygon [(0,0),(15,40),(20,25),(22,0)])
, outlined (solid 5) black (openPolygon [(15,40),(17,60), (19,65)])
, outlined (solid 5) black (openPolygon [(19,65),(7,56),(3,40)])
, outlined (solid 5) black (openPolygon [(19,65),(25,50),(35,40)])
, filled black (circle 10) |> move(20,70)
] |> move(20,0)
bent = group [
outlined (solid 5) black (openPolygon [(0,0),(13,17),(15,32),(25,15),(22,0)])
, outlined (solid 5) black (openPolygon [(15,32),(17,60), (19,65)])
, outlined (solid 5) black (openPolygon [(19,65),(7,56),(3,45)]) |> move(0,-8)
, outlined (solid 5) black (openPolygon [(19,65),(25,50),(35,45)]) |> move(0,-8)
, filled black (circle 10) |> move(20,70) |> move(0,-8)
] |> move(20,0)
jumping = group [
outlined (solid 5) black (openPolygon [(0,0),(13,17),(15,32),(25,15),(22,0)])
, outlined (solid 5) black (openPolygon [(15,32),(17,60), (19,65)])
, outlined (solid 5) black (openPolygon [(19,65),(7,56),(3,45)]) |> move(0,-8)
, outlined (solid 5) black (openPolygon [(19,65),(25,50),(35,45)]) |> move(0,-8)
, filled black (circle 10) |> move(20,70) |> move(0,-8)
] |> move(20,0)
-- don't edit below this point
type Stencil = Circle Float
| Rect Float Float
| RoundRect Float Float Float
| Oval Float Float
| BezierPath (Float,Float) (List(((Float,Float),(Float,Float))))
| Polygon (List (Float,Float))
| Path (List (Float,Float))
| Text Face String
type Shape notification = Inked Color (Maybe (LineType, Color)) Stencil
| Move (Float,Float) (Shape notification)
| Rotate Float (Shape notification)
| ScaleXY Float Float (Shape notification)
| Group (List (Shape notification))
| Link String (Shape notification)
| Tap notification (Shape notification)
| TapAt ((Float,Float) -> notification) (Shape notification)
| EnterShape notification (Shape notification)
| EnterAt ((Float,Float) -> notification) (Shape notification)
| Exit notification (Shape notification)
| ExitAt ((Float,Float) -> notification) (Shape notification)
| MouseDown notification (Shape notification)
| MouseDownAt ((Float,Float) -> notification) (Shape notification)
| MouseUp notification (Shape notification)
| MouseUpAt ((Float,Float) -> notification) (Shape notification)
| MoveOverAt ((Float,Float) -> notification) (Shape notification)
type Color = RGBA Float Float Float Float
type LineType = Solid Float
| Broken (List (Float,Float)) Float -- length of lines and gaps in pixels
type Face = Face Float -- size
Bool -- bold
Bool -- italic
Bool -- underline
Bool -- strikethrough
Bool -- selectable
Font
Bool -- centered
type Font = Serif | Sansserif | FixedWidth | Custom String
type Pull = Pull (Float,Float) (Float,Float)
type KeyState = JustDown | Down | JustUp | Up
type KeyAction = WentUp | WentDown
graphicsApp input = App.program { init = ((0,initGModel), initialSizeCmd input.view)
, update = blankUpdate
, view = blankView input.view
, subscriptions = \_ -> Sub.none } --Window.resizes sizeToMsg}
notificationApp input = App.program { init = ((input.model,initGModel), initialSizeCmd (input.view input.model))
, update = hiddenUpdate input.update
, view = hiddenView input.view
, subscriptions = \_ -> Sub.none }--Window.resizes sizeToMsg}
gameApp tickMsg input = App.program { init = ((input.model, { initGModel | updateTick = tickMsg }), initialSizeCmd (input.view input.model))
, update = hiddenGameUpdate input.update
, view = hiddenView input.view
, subscriptions = subs}
subs model =
Sub.batch ([ Time.every (1000/24*millisecond) (createTimeMessage) ])
-- AnimationFrame.times (createTimeMessage timeMsg)
{- , Window.resizes sizeToMsg] ++ keySubs)-}
--keySubs = [Keyboard.ups (KeyUp), Keyboard.downs (KeyDown)]
createTimeMessage t = let time = inSeconds t
in
TickTime time
blankUpdate msg (model,gModel) =
case msg of
Graphics message -> ((model, gModel), Cmd.none)
WindowResize (width,height) -> ((model, {gModel | sw = Basics.toFloat width, sh = Basics.toFloat height}), Cmd.none)
ReturnPosition message (x,y) -> ((model, gModel), Cmd.none)
CollageSize (width,height) -> ((model, {gModel | cw = Basics.toFloat width, ch = Basics.toFloat height }),Cmd.none)
InitTime t -> ((model, gModel), Cmd.none)
TickTime t -> ((model, gModel), Cmd.none)
KeyDown n -> ((model,gModel),Cmd.none)
KeyUp n -> ((model,gModel),Cmd.none)
NoOp -> ((model, gModel), Cmd.none)
hiddenUpdate update msg (model,gModel) =
case msg of
Graphics message -> ((update message model, gModel), Cmd.none)
WindowResize (width,height) -> ((model, {gModel | sw = Basics.toFloat width, sh = Basics.toFloat height}), Cmd.none)
ReturnPosition message (x,y) -> ((update (message (convertCoords (x,y) gModel)) model, gModel), Cmd.none)
CollageSize (width,height) -> ((model, {gModel | cw = Basics.toFloat width, ch = Basics.toFloat height }),Cmd.none)
InitTime t -> ((model, gModel),Cmd.none)
TickTime t -> ((model, gModel),Cmd.none)
KeyDown n -> ((model, gModel),Cmd.none)
KeyUp n -> ((model, gModel),Cmd.none)
NoOp -> ((model, gModel), Cmd.none)
hiddenGameUpdate update msg (model,gModel) = let
updateTick = gModel.updateTick
in
case msg of
Graphics message -> ((update message model, gModel), Cmd.none)
WindowResize (width,height) -> ((model, {gModel | sw = Basics.toFloat width, sh = Basics.toFloat height}), Cmd.none)
ReturnPosition message (x,y) -> ((update (message (convertCoords (x,y) gModel)) model, gModel), Cmd.none)
CollageSize (width,height) -> ((model, {gModel | cw = Basics.toFloat width, ch = Basics.toFloat height }),Cmd.none)
InitTime t -> ((model, { gModel | initT = t }),Cmd.none)
TickTime t -> ((update (gModel.updateTick (t-gModel.initT) ((keyCheckerFunction gModel.keys),arrowKeys (keyCheckerFunction gModel.keys), wasdKeys (keyCheckerFunction gModel.keys))) model, { gModel | keys = gModel.keys {-maintainKeyDict gModel.keys-} }), Cmd.none)
KeyDown n -> ((model, { gModel | keys = gModel.keys{- insertKeyDict gModel.keys n WentDown-} }), Cmd.none)
KeyUp n -> ((model, { gModel | keys = gModel.keys{- insertKeyDict gModel.keys n WentUp-} }), Cmd.none)
NoOp -> ((model, gModel), Cmd.none)
--Fake key functions
keyCheckerFunction dict keys = case keys of
_ -> Up
arrowKeys kcf = (0,0)
wasdKeys kcf = (0,0)
blankView view (model,gModel) =
case view of Collage (w,h) shapes -> createCollage w h shapes
hiddenView view (model,gModel) =
case (view model) of Collage (w,h) shapes -> createCollage w h shapes
convertCoords (x,y) gModel = let sw = gModel.sw
sh = gModel.sh
cw = gModel.cw
ch = gModel.ch
aspect = if not (sh == 0) then sw/sh else 4/3
scaledInX = aspect < 4/3
scaledInY = aspect > 4/3
scale = if scaledInX then sw/cw else if scaledInY then sh*0.99/ch else 1
newW = cw*scale
newH = ch*scale
leadX = if scaledInY then (sw-newW)/2 else 0
leadY = if scaledInX then (sh-newH)/2 else 0
offsetY = if scaledInX then -3 else 0
in ((x-leadX-newW/2)/scale,(y+leadY+offsetY+newH/2)/scale)
--initialSizeCmd : Cmd Msg
initialSizeCmd userView=
Cmd.batch[-- Task.perform (\_ -> NoOp) sizeToMsg Window.size
Task.perform (\_ -> NoOp) getCollageSize (Task.succeed userView)
, Task.perform (\_ -> NoOp) getInitTime Time.now]
getInitTime t = InitTime (inSeconds t)
{-sizeToMsg : Window.Size -> Msg a
sizeToMsg size =
WindowResize (size.width, size.height)-}
getCollageSize userView =
case userView of
Collage (w,h) _ -> CollageSize (round w, round h)
type Msg notes = Graphics notes
| WindowResize (Int,Int)
| ReturnPosition ((Float,Float) -> notes) (Float,Float)
| CollageSize (Int,Int)
| InitTime Time
| TickTime Time
| KeyDown Int
| KeyUp Int
| NoOp
aHiddenUpdate update msg model = (update msg model, Cmd.none)
aHiddenView view model = view model
type alias GModel a = {
cw: Float
, ch: Float
, sw: Float
, sh: Float
, initT: Float
, updateTick: a
-- , keys: KeyDict
}
initGModel = {
cw = 0
, ch = 0
, sw = 0
, sh = 0
, initT = 0
, updateTick = NoOp
, keys = Dict.empty
}
type alias GetKeyState = ((Keys -> KeyState),(Float,Float),(Float,Float))
type Keys = Key String
| Backspace
| Tab
| Enter
| Shift
| Ctrl
| Alt
| Caps
| LeftArrow
| UpArrow
| RightArrow
| DownArrow
| Delete
| Space
line : (Float,Float) -> (Float,Float) -> Stencil
line p1 p2 = Path [p1,p2]
polygon : List (Float,Float) -> Stencil
polygon ptList = Polygon ptList
openPolygon: List(Float,Float) -> Stencil
openPolygon ptList = Path ptList
ngon n r = Polygon <| List.map (ptOnCircle r n) [0..n]
triangle : Float -> Stencil
triangle r = ngon 3 r
square r = Rect r r
rect w h = Rect w h
roundedRect w h r = RoundRect w h r
rectangle w h = Rect w h
circle r = Circle r
oval x y = Oval x y
graphPaper s = group (List.map (createGraphX 1600 s) [-1500/s..1500/s] ++ List.map (createGraphY 3000 s) [-800/s..800/s])
createGraphX h s x = filled (rgb 135 206 250) (rect 1 h) |> move(x*s,0)
createGraphY w s y = filled (rgb 135 206 250) (rect w 1) |> move(0,y*s)
funnyStar r n frac = Polygon <| [(0,0)]
++ (List.map ((ptOnCircle r n) << ((*)(frac/10*180))) [-10..10])
++[(0,0)]
wedge r frac = let n = frac*360/10 + 5
in
Polygon <| [(0,0)]
++ (List.map ((wedgeHelper r) << ((*)(frac/n*180))) [-n..n])
++[(0,0)]
wedgeHelper r cn = let angle = cn
in
(r * cos (degrees angle), r * sin (degrees angle))
ptOnCircle r n cn = let angle = 360 * cn / n
in
(r * cos (degrees angle), r * sin (degrees angle))
curve: (Float,Float) -> List Pull -> Stencil
curve (a,b) list = BezierPath (a,b) (List.map curveListHelper list)
curveListHelper (Pull (a,b) (c,d)) = ((a,b),(c,d))
autoCurve: List (Float,Float) -> Stencil
autoCurve pts = let ar = Array.fromList pts
(sx,sy) = case (Array.get 0 ar) of
Just spt -> spt
Nothing -> (0,0)
length = List.length pts
in curve (sx,sy) (List.map (autoCurveListHelper ar length) [1..length-2])
autoCurveListHelper ar len n = let (x1,y1) = case (Array.get n ar) of
Just pt -> pt
Nothing -> (0,0)
(x2,y2) = case (Array.get (n+1) ar) of
Just pt -> pt
Nothing -> (0,0)
xc = (x1 + x2) / 2
yc = (y1 + y2) / 2
lastTwo = (n == len-2)
in if lastTwo then Pull (x1,-y1) (x2,y2) else Pull (xc,yc) (x1,y1)
addHyperlink link shape = Link link shape
text: String -> Stencil
text str = Text (Face 12 False False False False False Serif False) str
curveHelper: Shape notification -> Shape notification
curveHelper shape = case shape of
Inked clr outline (BezierPath (a,b) list) -> group [shape, generateCurveHelper (a,b) list ]
Move s shape -> Move s (curveHelper shape)
Rotate r shape -> Rotate r (curveHelper shape)
ScaleXY sx sy shape -> ScaleXY sx sy (curveHelper shape)
Group list -> Group (List.map curveHelper list)
a -> a
generateCurveHelper (a,b) list = let l1Array = Array.fromList ([(a,b)] ++ List.concat (List.map createTopLevelList list))
in group [generateCHLines l1Array, generateCHCircles l1Array]
generateCHLines ar = let len = Array.length ar
in group (List.map (generateCHLine ar) [0..(len-2)])
generateCHLine ar int = let p1 = case (Array.get int ar) of
Just p -> p
Nothing -> (0,0)
p2 = case (Array.get (int+1) ar) of
Just p -> p
Nothing -> (0,0)
in
outlined (dashed 0.5) black (line (p1) (p2))
generateCHCircles ar = let len = Array.length ar
in group (List.map (generateCHCircle ar) [0..(len-1)])
generateCHCircle ar int = let p1 = case (Array.get int ar) of
Just p -> p
Nothing -> (0,0)
ptStr = pairToString p1
in group [filled red (circle 2), text ("("++ptStr++")") |> filled black |> move(5,5) ] |> move p1
createTopLevelList ((a,b),(c,d)) = [(a,b),(c,d)]
--group: (List Shape) ->
type alias Transform = (((Float,Float) -- normal transformation of whole group
,(Float,Float)
,(Float,Float)
)
,((Float,Float),Float,(Float,Float)) -- scale/rotate/shift inside groups
)
coalesce (((a,b),(c,d),(tx,ty)),((sx,sy),rot,(shx,shy)))
= let sa = sx*a
sb = sy*b
sc = sx*c
sd = sy*d
rx = cos rot
ry = sin rot
in (((rx * sa - ry * sb, ry * sa + rx * sb)
,(rx * sc - ry * sd, ry * sc + rx * sd)
,(tx + a*shx + c*shy, ty + b*shx + d*shy))
,((1,1),0,(0,0))
)
id = (((1,0)
,(0,1)
,(0,0)
)
,((1,1),0,(0,0))
)
moveT : Transform -> (Float,Float) -> Transform
moveT (trans,(s,r,(tx,ty))) (u,v) = (trans,(s,r,(tx+u,ty+v)))
rotT (trans,(s,r,t)) rad = (trans,(s,r+rad,t))
scaleT (trans,((ssx,ssy),r,(shx,shy))) (sx,sy) = (trans,((ssx*sx,ssy*sy),r,(shx,shy)))
type Collage notification = Collage (Float,Float) (List (Shape notification))
--collage : Float -> Float -> (List (Shape notification)) -> Html.Html notification
collage w h shapes = Collage (w,h) shapes
createCollage w h shapes = Svg.svg
[ width "100%", height "99%", style "position:absolute", viewBox ((toString (-w/2)) ++ " " ++ (toString (-h/2)) ++ " " ++ (toString w) ++ " " ++(toString h))]
([cPath w h] ++ [Svg.g [clipPath "url(#cPath)"] (List.map (createSVG id) shapes)])
cPath w h =
Svg.defs [] [Svg.clipPath [Svg.Attributes.id "cPath"] [Svg.polygon [Svg.Attributes.points (toString (-w/2) ++ " " ++ (toString (-h/2)) ++ "," ++ (toString (w/2)) ++ " " ++ (toString (-h/2)) ++ "," ++ (toString (w/2)) ++ " " ++ (toString (h/2)) ++ "," ++ (toString(-w/2)) ++ " " ++ (toString (h/2)))] []]{-Svg.rect [width (toString w), height (toString h), x (toString (-w/2)), y (toString (-h/2))] []]-}]
f = 500 --focal length
--puppetShow : Float -> Float -> List (Float,Shape) -> Html.Html msg
puppetShow w h listShapes = collage w h (List.map extractShape (List.sortWith flippedComparison listShapes))
--extractShape: (Float,Shape notification) -> Shape notification
extractShape (z,shape) = let s = f/(f+z)
in group [shape] |> scale s
flippedComparison (a,x) (b,y) =
case compare a b of
LT -> GT
EQ -> EQ
GT -> LT
--Notification functions
notifyTap msg shape = Tap (Graphics msg) shape
notifyEnter msg shape = EnterShape (Graphics msg) shape
notifyLeave msg shape = Exit (Graphics msg) shape
notifyTapAt msg shape = TapAt (ReturnPosition msg) shape
notifyEnterAt msg shape = EnterAt (ReturnPosition msg) shape
notifyLeaveAt msg shape = ExitAt (ReturnPosition msg) shape
notifyMoveOverAt msg shape = MoveOverAt (ReturnPosition msg) shape
notifyPointerDown msg shape = MouseDown (Graphics msg) shape
notifyPointerDownAt msg shape = MouseDownAt (ReturnPosition msg) shape
notifyPointerUp msg shape = MouseUp (Graphics msg) shape
notifyPointerUpAt msg shape = MouseUpAt (ReturnPosition msg) shape
xyToPair xy = (Basics.toFloat (xy.x),Basics.toFloat (-xy.y))
onTapAt msg =
Html.Events.on "click"
(Json.map (msg << xyToPair) Mouse.position)
onEnterAt msg =
Html.Events.on "mouseover"
(Json.map (msg << xyToPair) Mouse.position)
onLeaveAt msg =
Html.Events.on "mouseleave"
(Json.map (msg << xyToPair) Mouse.position)
onMoveAt msg =
Html.Events.on "mousemove"
(Json.map (msg << xyToPair) Mouse.position)
onMouseDownAt msg =
Html.Events.on "mousedown"
(Json.map (msg << xyToPair) Mouse.position)
onMouseUpAt msg =
Html.Events.on "mouseup"
(Json.map (msg << xyToPair) Mouse.position)
onTouchStart msg =
Html.Events.on "touchstart" (Json.succeed msg)
onTouchEnd msg =
Html.Events.on "touchend" (Json.succeed msg)
onTouchMove msg =
Html.Events.on "touchmove"
(Json.map (msg << xyToPair) Mouse.position)
--createSVG : Transform -> Shape notification -> Svg.Svg notification
createSVG trans shape =
case shape of
Inked fillClr lt stencil
-> let (((a,b),(c,d),(tx,ty)),_) = coalesce trans
attrs = transAttrs ++ clrAttrs ++ strokeAttrs
transAttrs = [Svg.Attributes.transform <| "matrix("++(String.concat <| List.intersperse "," <| List.map toString [a,-b,c,-d,tx,-ty])++")"]
clrAttrs = [ fill (mkRGB fillClr), fillOpacity (mkAlpha fillClr)]
strokeAttrs = case lt of
Nothing -> []
Just (Solid w , strokeClr) -> [ strokeWidth (toString w)
, stroke (mkRGB strokeClr), strokeOpacity (mkAlpha strokeClr)]
Just (Broken dashes w , strokeClr) -> [ strokeWidth (toString w)
, stroke (mkRGB strokeClr), strokeOpacity (mkAlpha strokeClr)]
++ [strokeDasharray <| String.concat (List.intersperse "," <| List.map pairToString dashes)]
in (case stencil of
Circle r -> Svg.circle ([ cx "0", cy "0"
, Svg.Attributes.r (toString r) ] ++ attrs) []
Rect w h -> Svg.rect ([ x (toString (-w/2)), y (toString (-h/2))
, width (toString w), height (toString h)] ++ attrs) []
RoundRect w h r -> Svg.rect ([ x (toString (-w/2)), y (toString (-h/2))
, rx (toString r), ry (toString r)
, width (toString w), height (toString h)] ++ attrs) []
Oval w h -> Svg.ellipse ([ cx "0", cy "0"
, rx (toString (0.5*w)), ry (toString (0.5*h)) ] ++ attrs) []
-- BezierPath (List )
Polygon vertices -> Svg.polygon ([points <| String.concat <| List.intersperse " " <| List.map pairToString vertices]
++ attrs) []
Path vertices -> Svg.polyline ([points <| String.concat <| List.intersperse " " <| List.map pairToString vertices]
++ attrs) []
BezierPath start pts -> Svg.path ([Svg.Attributes.d <| (createBezierString start pts)]
++ attrs) []
Text (Face si bo i u s sel f cen) str -> let bol = if bo then "font-weight: bold;" else ""
it = if i then "font-style: italic;" else ""
un = if u then "text-decoration: underline;" else ""
stri = if s then "text-decoration: strikethrough;" else ""
select = if not sel then "-webkit-touch-callout: none;
-webkit-user-select: none;
-khtml-user-select: none;
-moz-user-select: none;
-ms-user-select: none;
user-select: none;cursor: default;"
else ""
anchor = if cen then "middle" else "left"
font = case f of
Sansserif -> "sansserif;"
FixedWidth -> "fixedwidth;"
Custom fStr -> fStr ++ ";"
_ -> "serif"
sty = bol ++ it ++ un ++ stri ++
"font-family: " ++ font ++ select
in Svg.text' ([ x (toString tx), y (toString -ty), Svg.Attributes.style sty, Svg.Attributes.fontSize (toString (si)), Svg.Attributes.textAnchor anchor] ++ attrs ++ [Svg.Attributes.transform <| "matrix("++(String.concat <| List.intersperse "," <| List.map toString [a,b,c,d,0,0])++")"]) [Svg.text str]
)
Move v shape -> createSVG (moveT trans v) shape
Rotate deg shape -> createSVG (rotT trans deg) shape
ScaleXY sx sy shape -> createSVG (scaleT trans (sx,sy)) shape
Link href shape -> Svg.a [xlinkHref href, target "_blank"] [createSVG (coalesce trans) shape]
Tap msg shape -> Svg.g [Html.Events.onClick msg] [createSVG (coalesce trans) shape]
TapAt msg shape -> Svg.g [onTapAt msg] [createSVG (coalesce trans) shape]
EnterShape msg shape -> Svg.g [Html.Events.onMouseEnter msg] [createSVG (coalesce trans) shape]
EnterAt msg shape -> Svg.g [onEnterAt msg] [createSVG (coalesce trans) shape]
Exit msg shape -> Svg.g [Html.Events.onMouseLeave msg] [createSVG (coalesce trans) shape]
ExitAt msg shape -> Svg.g [onLeaveAt msg] [createSVG (coalesce trans) shape]
MouseDown msg shape -> Svg.g [Html.Events.onMouseDown msg] [createSVG (coalesce trans) shape]
MouseDownAt msg shape -> Svg.g [onMouseDownAt msg] [createSVG (coalesce trans) shape]
MouseUp msg shape -> Svg.g [Html.Events.onMouseUp msg] [createSVG (coalesce trans) shape]
MouseUpAt msg shape -> Svg.g [onMouseUpAt msg] [createSVG (coalesce trans) shape]
MoveOverAt msg shape -> Svg.g [onMoveAt msg] [createSVG (coalesce trans) shape]
Group shapes -> Svg.g [] <| List.map (createSVG <| coalesce trans) shapes
--Filling / outlining functions
filled: Color -> Stencil -> Shape notification
filled color shape = Inked color Nothing shape
outlined: LineType -> Color -> Stencil -> Shape notification
outlined style outlineClr shape = let lineStyle = (style, outlineClr)
in Inked (rgba 0 0 0 0) (Just lineStyle) shape
addOutline: LineType -> Color -> Shape notification -> Shape notification
addOutline style outlineClr shape = let lineStyle = (style, outlineClr)
in
case shape of
Inked clr outline shape -> Inked clr (Just lineStyle) shape
Move s shape -> Move s (addOutline style outlineClr shape)
Rotate r shape -> Rotate r (addOutline style outlineClr shape)
ScaleXY sx sy shape -> ScaleXY sx sy (addOutline style outlineClr shape)
Group list -> Group list
a -> a
makeTransparent: Float -> Shape notification -> Shape notification
makeTransparent alpha shape = case shape of
Inked (RGBA r g b a) (Just (lineType, (RGBA sr sg sb sa))) shape -> Inked (RGBA r g b (a*alpha)) (Just (lineType, (RGBA sr sg sb (sa*alpha)))) shape
Inked (RGBA r g b a) Nothing shape -> Inked (RGBA r g b (a*alpha)) Nothing shape
Move s shape -> Move s (makeTransparent alpha shape)
Rotate r shape -> Rotate r (makeTransparent alpha shape)
ScaleXY sx sy shape -> ScaleXY sx sy (makeTransparent alpha shape)
Group list -> Group (List.map (makeTransparent alpha) list)
a -> a
--Line styles
solid th = Solid th
dotted th = Broken [(th,th)] th
dashed th = Broken [(th*5,th*2.5)] th
longdash th = Broken [(th*12,th*6)] th
dotdash th = Broken [(th,th),(th*5,th)] th
custom list th = Broken list th
increasing s e th = Broken (List.map makePair [s..e]) th
makePair n = (n,n)
--Text functions
size size stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face size bo i u s sel f c) str
a -> a
bold stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si True i u s sel f c) str
a -> a
italic stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo True u s sel f c) str
a -> a
underline stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo i True s sel f c) str
a -> a
strikethrough stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo i u True sel f c) str
a -> a
selectable stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo i u s True f c) str
a -> a
centered stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo i u s sel f True) str
a -> a
sansserif stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo i u s sel Sansserif c) str
a -> a
customFont fStr stencil = case stencil of
(Text (Face si bo i u s sel f c) str) -> Text (Face si bo i u s sel (Custom fStr) c) str
a -> a
--Transformation functions
rotate theta shape = Rotate theta shape
move disp shape = Move disp shape
scale s shape = ScaleXY s s shape
scaleX s shape = ScaleXY s 1 shape
scaleY s shape = ScaleXY 1 s shape
mirrorX shape = ScaleXY -1 1 shape
mirrorY shape = ScaleXY 1 -1 shape
group shapes = Group shapes
rgb r g b = RGBA r g b 1
rgba r g b a = RGBA r g b a
degrees: Float -> Float
degrees deg = deg*(pi/180)
pairToString (x,y) = (toString x)++","++(toString y)
createBezierString first list = "M " ++ (pairToString first) ++ String.concat (List.map bezierStringHelper list)
bezierStringHelper ((a,b),(c,d)) = " Q " ++ pairToString (a,b) ++ " " ++ pairToString (c,d)
mkAlpha (RGBA _ _ _ a) = toString a
mkRGB (RGBA r g b _) = "#" ++ (toHex <| round r) ++ (toHex <| round g) ++ (toHex <| round b)
toHex: Int -> String
toHex dec = let first = dec // 16
second = (dec % 16)
in (toHexHelper first) ++ (toHexHelper second)
toHexHelper: Int -> String
toHexHelper dec = case dec of
0 -> "0"
1 -> "1"
2 -> "2"
3 -> "3"
4 -> "4"
5 -> "5"
6 -> "6"
7 -> "7"
8 -> "8"
9 -> "9"
10 -> "A"
11 -> "B"
12 -> "C"
13 -> "D"
14 -> "E"
15 -> "F"
_ -> ""
--
pink: Color
pink =
RGBA 255 105 180 1
hotPink: Color
hotPink =
RGBA 255 0 66 1
{-|-}
lightRed : Color
lightRed =
RGBA 239 41 41 1
{-|-}
red : Color
red =
RGBA 204 0 0 1
{-|-}
darkRed : Color
darkRed =
RGBA 164 0 0 1
{-|-}
lightOrange : Color
lightOrange =
RGBA 252 175 62 1
{-|-}
orange : Color
orange =
RGBA 245 121 0 1
{-|-}
darkOrange : Color
darkOrange =
RGBA 206 92 0 1
{-|-}
lightYellow : Color
lightYellow =
RGBA 255 233 79 1
{-|-}
yellow : Color
yellow =
RGBA 237 212 0 1
{-|-}
darkYellow : Color
darkYellow =
RGBA 196 160 0 1
{-|-}
lightGreen : Color
lightGreen =
RGBA 138 226 52 1
{-|-}
green : Color
green =
RGBA 115 210 22 1
{-|-}
darkGreen : Color
darkGreen =
RGBA 78 154 6 1
{-|-}
lightBlue : Color
lightBlue =
RGBA 114 159 207 1
{-|-}
blue : Color
blue =
RGBA 52 101 164 1
{-|-}
darkBlue : Color
darkBlue =
RGBA 32 74 135 1
{-|-}
lightPurple : Color
lightPurple =
RGBA 173 127 168 1
{-|-}
purple : Color
purple =
RGBA 117 80 123 1
{-|-}
darkPurple : Color
darkPurple =
RGBA 92 53 102 1
{-|-}
lightBrown : Color
lightBrown =
RGBA 233 185 110 1
{-|-}
brown : Color
brown =
RGBA 193 125 17 1
{-|-}
darkBrown : Color
darkBrown =
RGBA 143 89 2 1
{-|-}
black : Color
black =
RGBA 0 0 0 1
{-|-}
white : Color
white =
RGBA 255 255 255 1
{-|-}
lightGrey : Color
lightGrey =
RGBA 238 238 236 1
{-|-}
grey : Color
grey =
RGBA 211 215 207 1
{-|-}
darkGrey : Color
darkGrey =
RGBA 186 189 182 1
{-|-}
lightGray : Color
lightGray =
RGBA 238 238 236 1
{-|-}
gray : Color
gray =
RGBA 211 215 207 1
{-|-}
darkGray : Color
darkGray =
RGBA 186 189 182 1
{-|-}
lightCharcoal : Color
lightCharcoal =
RGBA 136 138 133 1
{-|-}
charcoal : Color
charcoal =
RGBA 85 87 83 1
{-|-}
darkCharcoal : Color
darkCharcoal =
RGBA 46 52 54 1
blank : Color
blank = RGBA 0 0 0 0