Ordinary 0.2018.1.3 → 0.2018.1.4

raw patch · 2 files changed

+71/−8 lines, 2 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• Ordinary.cabal +2/−2
• src/Lib.hs +69/−6

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9909577fb7437b58a07f0ec82a4f7210e1deae44f65f791093471b1b3806d17d+-- hash: ebc3c9bd3445afb4088fcc7e3f742e5565a5fd65b9b047efb8617eee3beb80f2  name:           Ordinary-version:        0.2018.1.3+version:        0.2018.1.4 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

@@ -7,6 +7,7 @@ import qualified Graphics.UI.Threepenny as UI import Graphics.UI.Threepenny.Core import Safe+import Data.List  someFunc :: IO () someFunc = startGUI defaultConfig setup@@ -42,8 +43,8 @@ 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+  let mouseDownMove = fmap (\x (Reversed xs) -> Reversed (x:xs)) $ filterApply mouseIsDown $ UI.mousemove e+  let mouseUpClear = fmap (const $ const $ Reversed []) $ UI.mouseup e   accumB (Reversed []) (unionWith undefined mouseDownMove mouseUpClear)  mouseStroke :: MonadIO m => Element -> m (Event (Reversed (Int, Int)))@@ -54,19 +55,81 @@ 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 +thin :: Double -> [UI.Point] -> [UI.Point]+thin dist [] = []+thin dist (x@(lx, ly):xs) = x : thin dist (dropWhile (\(rx, ry) -> (lx - rx) ** 2 + (ly - ry) ** 2 < dist ** 2) xs)++data Curvature = CUp | CDown | CLeft | CRight deriving (Eq, Ord, Show)++mapBetween :: (a -> a -> b) -> [a] -> [b]+mapBetween f x | length x < 2 = []+mapBetween f x = zipWith f x (tail x)++mapBetween4 :: (a -> a -> a -> a -> b) -> [a] -> [b]+mapBetween4 f x | length x < 4 = []+mapBetween4 f x = zipWith4 f x tx ttx tttx+  where+    tx = tail x+    ttx = tail tx+    tttx = tail ttx++direction :: UI.Point -> UI.Point -> Curvature+direction (lx, ly) (rx, ry) =+  if abs (lx - rx) < abs (ly - ry)+  then if ly < ry then CDown else CUp+  else if lx < rx then CRight else CLeft++directions :: [UI.Point] -> [Curvature]+directions = map head . group . mapBetween direction++toPoint :: (Int, Int) -> UI.Point+toPoint (x, y) = (fromIntegral x, fromIntegral y)++withAngles :: [UI.Point] -> [(UI.Point, Double)]+withAngles = mapBetween (\(lx, ly) (rx, ry) -> ((rx, ry), atan2 (ly - ry) (rx - lx)))++corners :: Double -> Double -> [UI.Point] -> [UI.Point]+corners sameLimit changeLimit =+  map fst . filter snd .+  mapBetween4 (\(_, a0) (_, a1) (p, a2) (_, a3) -> (p, abs (a0 - a1) < sameLimit && abs (a2 - a3) < sameLimit && abs (a1 - a2) > changeLimit)) .+  withAngles++data Grid = Grid { gridLeftTop :: UI.Point, gridRightDown :: UI.Point }++makeGrid :: [UI.Point] -> Maybe Grid+makeGrid [] = Nothing+makeGrid l = Just $ Grid (left, top) (right, down)+  where+    xs = map fst l+    ys = map snd l+    left = minimum xs+    right = maximum xs+    top = minimum ys+    down = maximum ys++locateInRange :: Double -> Double -> Int -> Double -> Maybe Int+locateInRange down up numBracket val = if down <= val && val <= up then Just (min (floor ((val - down) / (up - down) * (fromIntegral numBracket))) numBracket) else Nothing+ +locateInGrid :: Grid -> Int -> Int -> UI.Point -> Maybe (Int, Int)+locateInGrid (Grid (left, top) (right, down)) numCol numRow (x, y) = do+  x' <- locateInRange left right numCol x+  y' <- locateInRange top down numRow y+  return (x', y')+ 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+  smoothFact <- stepper 0.5 $ filterJust $ fmap (readMay :: String -> 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)+      let points = map toPoint $ reverse x       mapM (\p -> circle blue p 5 wrap) points       smoothFactCur <- currentValue smoothFact-      mapM (\p -> circle black p 5 wrap) (smooth smoothFactCur points)+      let processedPoints = thin 20 $ smooth smoothFactCur points+      mapM (\p -> circle black p 5 wrap) $ processedPoints+      mapM (\p -> circle black p 20 wrap) $ corners (pi/6) (pi/3) processedPoints   return ()