Ordinary (empty) → 0.2018.1.3

raw patch · 8 files changed

+185/−0 lines, 8 filesdep +Ordinarydep +basedep +safesetup-changed

Dependencies added: Ordinary, base, safe, threepenny-gui

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• Ordinary.cabal +69/−0
• README.md +1/−0
• Setup.hs +2/−0
• app/Main.hs +6/−0
• src/Lib.hs +72/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,3 @@+# Changelog for Ordinary++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Marisa Kirisame (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marisa Kirisame nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,69 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9909577fb7437b58a07f0ec82a4f7210e1deae44f65f791093471b1b3806d17d++name:           Ordinary+version:        0.2018.1.3+synopsis:       Short description of your package+description:    Please see the README on Github at <https://github.com/MarisaKirisame/Ordinary#readme>+homepage:       https://github.com/MarisaKirisame/Ordinary#readme+bug-reports:    https://github.com/MarisaKirisame/Ordinary/issues+author:         Marisa Kirisame+maintainer:     lolisa@marisa.moe+copyright:      2018 Marisa Kirisame+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/MarisaKirisame/Ordinary++library+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , safe ==0.3.15+    , threepenny-gui ==0.8.2.0+  exposed-modules:+      Lib+  other-modules:+      Paths_Ordinary+  default-language: Haskell2010++executable Ordinary-exe+  main-is: Main.hs+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      Ordinary+    , base >=4.7 && <5+    , safe ==0.3.15+    , threepenny-gui ==0.8.2.0+  other-modules:+      Paths_Ordinary+  default-language: Haskell2010++test-suite Ordinary-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      Ordinary+    , base >=4.7 && <5+    , safe ==0.3.15+    , threepenny-gui ==0.8.2.0+  other-modules:+      Paths_Ordinary+  default-language: Haskell2010

@@ -0,0 +1,1 @@+# Ordinary

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,6 @@+module Main where++import Lib++main :: IO ()+main = someFunc

@@ -0,0 +1,72 @@+{-# LANGUAGE PartialTypeSignatures #-}++module Lib+    ( someFunc+    ) where++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core+import Safe++someFunc :: IO ()+someFunc = startGUI defaultConfig setup++class PrintType a where+    printType :: a -> b++black = "#000000"+blue = "#66CCFF"++circle :: String -> UI.Point -> Double -> UI.Canvas -> UI ()+circle color p r c = do+  c # set' UI.fillStyle (UI.htmlColor color)+  c # UI.beginPath+  c # UI.arc p r (-pi) pi+  c # UI.closePath+  c # UI.fill++wrapper :: Int -> Int -> UI Element+wrapper width height =+  UI.canvas+    # set UI.height height+    # set UI.width width+    # set style [("border", "solid black 1px")]++data MouseState = MouseUp | MouseDown deriving Eq++newtype Reversed a = Reversed [a]++mouseState :: MonadIO m => Element -> m (Behavior MouseState)+mouseState e = MouseUp `stepper` unionWith undefined (MouseDown <$ UI.mousedown e) (MouseUp <$ UI.mouseup e)++currentStroke :: MonadIO m => Element -> m (Behavior (Reversed (Int, Int)))+currentStroke e = do+  mouseIsDown <- (fmap . fmap) (const . (== MouseDown)) $ mouseState e+  mouseDownMove <- return $ fmap (\x (Reversed xs) -> Reversed (x:xs)) $ filterApply mouseIsDown $ UI.mousemove e+  mouseUpClear <- return $ fmap (const $ const $ Reversed []) $ UI.mouseup e+  accumB (Reversed []) (unionWith undefined mouseDownMove mouseUpClear)++mouseStroke :: MonadIO m => Element -> m (Event (Reversed (Int, Int)))+mouseStroke e = do+  l <- currentStroke e+  return $ l <@ UI.mouseup e++smooth :: Double -> [UI.Point] -> [UI.Point]+smooth smoothFact x = scanl1 (\(xl, xr) (yl, yr) -> (smoothFact * xl + (1 - smoothFact) * yl, smoothFact * xr + (1 - smoothFact) * yr)) x++setup :: Window -> UI ()+setup w = do+  return w # set UI.title "Ordinary"+  wrap <- wrapper 1024 640+  smoothFactIn <- UI.input+  getBody w #+ [row [element wrap, column [string "smooth by", element smoothFactIn]]]+  smoothFact <- stepper 0.5 $ filterJust $ fmap (readMay :: _ -> Maybe Double) $ UI.valueChange smoothFactIn+  stroke <- mouseStroke wrap+  unEvent <- onEvent stroke $+    \(Reversed x) -> do+      return w # set UI.title (show (reverse x))+      points <- return $ map (\(l, r) -> (fromIntegral l, fromIntegral r)) (reverse x)+      mapM (\p -> circle blue p 5 wrap) points+      smoothFactCur <- currentValue smoothFact+      mapM (\p -> circle black p 5 wrap) (smooth smoothFactCur points)+  return ()

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"