diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `moffy-samples` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yoshikuni Jujo (c) 2023 + +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 Yoshikuni Jujo 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# moffy-samples diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/moffy-samples.cabal b/moffy-samples.cabal new file mode 100644 --- /dev/null +++ b/moffy-samples.cabal @@ -0,0 +1,81 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.35.2. +-- +-- see: https://github.com/sol/hpack + +name: moffy-samples +version: 0.1.0.0 +synopsis: Samples of moffy +description: Please see the README on GitHub at +category: Control +homepage: https://github.com/YoshikuniJujo/moffy-samples#readme +bug-reports: https://github.com/YoshikuniJujo/moffy-samples/issues +author: Yoshikuni Jujo +maintainer: yoshikuni.jujo@gmail.com +copyright: Copyright (c) 2023 Yoshikuni Jujo +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/YoshikuniJujo/moffy-samples + +library + exposed-modules: + Control.Moffy.Samples.Boxes + Control.Moffy.Samples.Followbox + Lib + other-modules: + Paths_moffy_samples + autogen-modules: + Paths_moffy_samples + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + JuicyPixels + , aeson + , base >=4.7 && <5 + , bytestring + , extra-data-yj + , moffy + , moffy-samples-events + , text + , time + , transformers + , type-flip + , type-set + , unordered-containers + default-language: Haskell2010 + +test-suite moffy-samples-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_moffy_samples + autogen-modules: + Paths_moffy_samples + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + JuicyPixels + , aeson + , base >=4.7 && <5 + , bytestring + , extra-data-yj + , moffy + , moffy-samples + , moffy-samples-events + , text + , time + , transformers + , type-flip + , type-set + , unordered-containers + default-language: Haskell2010 diff --git a/src/Control/Moffy/Samples/Boxes.hs b/src/Control/Moffy/Samples/Boxes.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Boxes.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Control.Moffy.Samples.Boxes where + +import Prelude hiding (until, repeat, cycle) + +import Control.Arrow qualified as A +import Control.Monad +import Control.Monad.Trans.Except (pattern ExceptT, runExceptT) +import Control.Moffy +import Control.Moffy.Event.Time +import Control.Moffy.Samples.Event.Mouse qualified as Mouse +import Control.Moffy.Samples.Boxes.Viewable +import Data.Type.Set +import Data.Type.Flip +import Data.Bool +import Data.Or +import Data.List.NonEmpty (fromList) +import Data.List.Infinite (Infinite(..), cycle) + +sameClick :: React s (Singleton Mouse.Down) Bool +sameClick = do + pressed <- Mouse.down + pressed2 <- Mouse.down + pure $ pressed == pressed2 + +clickOn :: Mouse.Button -> React s (Singleton Mouse.Down) () +clickOn b0 = do + b <- Mouse.down + bool (clickOn b0) (pure ()) (b == b0) + +leftClick, middleClick, rightClick :: React s (Singleton Mouse.Down) () +leftClick = clickOn Mouse.ButtonPrimary +middleClick = clickOn Mouse.ButtonMiddle +rightClick = clickOn Mouse.ButtonSecondary + +releaseOn :: Mouse.Button -> React s (Singleton Mouse.Up) () +releaseOn b0 = do + b <- Mouse.up + bool (releaseOn b0) (pure ()) (b == b0) + +leftUp :: React s (Singleton Mouse.Up) () +leftUp = releaseOn Mouse.ButtonPrimary + +before :: Firstable es es' a b => + React s es a -> React s es' b -> React s (es :+: es') Bool +l `before` r = (\case L _ -> True; _ -> False) <$> l `first` r + +doubler :: React s (TryWait :- Singleton Mouse.Down) () +doubler = adjust rightClick >> + rightClick `before` sleep 0.2 >>= bool doubler (pure ()) + +curRect :: Point -> Sig s (Singleton Mouse.Move) Rect () +curRect p1 = Rect p1 <$%> Mouse.position + +wiggleRect :: Rect -> Sig s (Singleton DeltaTime) Rect r +wiggleRect (Rect lu rd) = rectAtTime <$%> elapsed + where rectAtTime t = let dx = sin (realToFrac t * 5) * 15 in + Rect ((+ dx) `A.first` lu) ((+ dx) `A.first` rd) + +posInside :: Rect -> Sig s es Point r -> React s es (Either Point r) +posInside rct = find (`inside` rct) + where (x, y) `inside` Rect (l, u) (r, d) = + (l <= x && x <= r || r <= x && x <= l) && + (u <= y && y <= d || d <= y && y <= u) + +firstPoint :: React s (Mouse.Down :- Mouse.Move :- 'Nil) (Either String Point) +firstPoint = atResult (const "firstPoint 1") (const "firstPoint 2") + <$> Mouse.position `at` leftClick + +completeRect :: Point -> + Sig s (Mouse.Up :- Mouse.Move :- 'Nil) Rect (Either String Rect) +completeRect p1 = const (Left "never occur") `either` (Right . fst) + <$> curRect p1 `until` leftUp + +defineRect :: Sig s Mouse.Events Rect Rect +defineRect = either error pure =<< runExceptT do + p1 <- ExceptT . waitFor $ adjust firstPoint + ExceptT . adjustSig $ completeRect p1 + +cycleColor :: Sig s (Mouse.Down :- 'Nil) BColor () +cycleColor = go . cycle $ fromList [Red .. Magenta] where + go (h :~ t) = do + emit h + (bool (pure ()) (go t) + =<< waitFor (middleClick `before` rightClick)) + +chooseBoxColor :: Rect -> Sig s (Mouse.Down :- DeltaTime :- 'Nil) Box () +chooseBoxColor r = Box <$%> adjustSig (wiggleRect r) <*%> adjustSig cycleColor + +drClickOn :: Rect -> React s (Mouse.Down :- Mouse.Move :- TryWait :- 'Nil) () +drClickOn rct = void . posInside rct + . (fst <$%>) $ Mouse.position `indexBy` repeat doubler + +box :: Sig s (Mouse.Events :+: DeltaTime :- TryWait :- 'Nil) Box () +box = (`Box` Red) <$%> adjustSig defineRect >>= \b -> do + adjustSig $ chooseBoxColor b + waitFor . adjust $ drClickOn b + +boxes :: Sig s (Mouse.Events :+: DeltaTime :- TryWait :- 'Nil) [Box] () +boxes = () <$ parList (spawn box) diff --git a/src/Control/Moffy/Samples/Followbox.hs b/src/Control/Moffy/Samples/Followbox.hs new file mode 100644 --- /dev/null +++ b/src/Control/Moffy/Samples/Followbox.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE BlockArguments, LambdaCase, TupleSections, OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wall -fno-warn-tabs #-} + +module Control.Moffy.Samples.Followbox ( + -- * followbox + followbox ) where + +import Prelude hiding (break, until) + +import Control.Arrow ((>>>)) +import Control.Monad (void, forever, (<=<)) +import Control.Moffy (adjust, emit, waitFor, first, break, until) +import Control.Moffy.Event.Lock (LockId, newLockId, withLock) +import Control.Moffy.Samples.Event.Random (getRandomR) +import Control.Moffy.Samples.Event.Delete (deleteEvent) +import Control.Moffy.Samples.Viewable.Basic (Position) +import Control.Moffy.Samples.Followbox.Event ( + SigF, ReactF, + clearJsons, storeJsons, loadJsons, httpGet, getTimeZone, + browse, beginSleep, checkBeginSleep, endSleep, + Error(..), raiseError, checkTerminate ) +import Control.Moffy.Samples.Followbox.Clickable ( + Clickable, view, click, clickable, clickableText, + WithTextExtents, withTextExtents, nextToText, translate, + FontName, FontSize ) +import Control.Moffy.Samples.Followbox.ViewType ( + View(..), View1, white, Png(..), VText(..), Line(..), Image(..) ) +import Control.Moffy.Samples.Followbox.TypeSynonym (ErrorMessage, Uri) +import Data.Type.Flip ((<$%>), (<*%>), ftraverse) +import Data.OneOfThem +import Data.Or (Or(..)) +import Data.HashMap.Strict qualified as HM +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BSC +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as T +import Data.Time (utcToLocalTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Aeson (Object, Value(..), eitherDecode) +import Data.Aeson.KeyMap (toHashMap) +import Text.Read (readMaybe) +import Codec.Picture qualified as P + +--------------------------------------------------------------------------- + +-- * PARAMETER LIST +-- + NUMBER OF USER TO DISPLAY +-- + MAX NUMBER OF GITHUB USER +-- + BACKGROUND +-- + FONT +-- + AVATAR, NAME AND CROSS +-- * SIG AND REACT +-- + FOLLOWBOX +-- + USERS +-- + GET USER +-- + GET OBJECT + +--------------------------------------------------------------------------- +-- PARAMETER LIST +--------------------------------------------------------------------------- + +-- NUMBER OF USER TO DISPLAY + +numOfUsers :: Integer +numOfUsers = 3 + +-- MAX NUMBER OF GITHUB USER + +userPageMax :: Int +userPageMax = 2 ^ (27 :: Int) + +-- BACKGROUND + +titlePos, nextPos, refreshPos, resetTimePos :: Position +titlePos = (50, 44); nextPos = (500, 44) +refreshPos = (600, 44); resetTimePos = (100, 470) + +-- FONT + +defaultFont :: FontName +defaultFont = "sans" + +middleSize, largeSize :: FontSize +middleSize = 30; largeSize = 36 + +-- AVATAR, NAME AND CROSS + +avatarSizeX, avatarSizeY :: Double +(avatarSizeX, avatarSizeY) = (80, 80) + +avatarPos, namePos :: Double -> Position +avatarPos n = (100, 120 + 120 * n) +namePos n = (210, 150 + 120 * n) + +crossSize :: Double +crossSize = largeSize / 2 + +crossPos :: Position -> WithTextExtents -> Position +crossPos p wte = translate (nextToText p wte) wte (1 / 2, 3 / 8) + +crossMergin :: Double +crossMergin = 4 + +--------------------------------------------------------------------------- +-- SIG AND REACT +--------------------------------------------------------------------------- + +-- FOLLOWBOX + +followbox :: SigF s View () +followbox = () <$ + fieldWithResetTime numOfUsers `break` deleteEvent `break` checkTerminate + +fieldWithResetTime :: Integer -> SigF s View () +fieldWithResetTime n = (<>) <$%> field n <*%> resetTime + +field :: Integer -> SigF s View () +field n = do + (nxt, rfs) <- waitFor + $ (,) <$> link nextPos "Next" <*> link refreshPos "Refresh" + let frame = View [title] <> view nxt <> view rfs; clear = emit frame + lck <- waitFor $ adjust newLockId + (clear >>) . forever $ (frame <>) + <$%> users lck n `until` click nxt `first` click rfs >>= \case + Right (_, L _) -> pure () + Right (_, LR _ _) -> pure () + Right (_, R _) -> clear >> waitFor (adjust clearJsons) + Left _ -> error "never occur" + where + title = twhite largeSize titlePos "Who to follow" + link p t = clickableText p + <$> adjust (withTextExtents defaultFont middleSize t) + +resetTime :: SigF s View () +resetTime = forever $ emit (View []) >> do + emit =<< waitFor do + (t, tz) <- (,) <$> adjust checkBeginSleep <*> adjust getTimeZone + pure $ View [twhite middleSize resetTimePos . T.pack + $ "Wait until " <> show (utcToLocalTime tz t)] + waitFor $ adjust endSleep + +twhite :: FontSize -> Position -> T.Text -> View1 +twhite fs p = expand . Singleton . Text' white defaultFont fs p + +-- USERS + +users :: LockId -> Integer -> SigF s View () +users lck (fromIntegral -> n) = + mconcat <$%> (forever . user1 lck) `ftraverse` [0 .. n - 1] + +user1 :: LockId -> Double -> SigF s View () +user1 lck n = do + (avt, nm, uri) <- waitFor $ getUser lck + wte <- waitFor . adjust $ withTextExtents defaultFont largeSize nm + let ap = avatarPos n; np = namePos n + lnk = clickableText np wte; cr = cross $ crossPos np wte + emit $ View [expand . Singleton $ Image' ap avt] <> view lnk <> view cr + void $ waitFor (listenForUserPage lnk uri) `break` click cr + +listenForUserPage :: Clickable s -> Uri -> ReactF s () +listenForUserPage nm u = forever $ adjust (click nm) >> adjust (browse u) + +cross :: Position -> Clickable s +cross (l, t) = clickable (View [lwhite lt rb, lwhite lb rt]) (l', t') (r', b') + where + (lt, lb, rt, rb) = ((l, t), (l, b), (r, t), (r, b)) + (r, b) = (l + crossSize, t + crossSize) + (l', t') = (l - crossMergin, t - crossMergin) + (r', b') = (r + crossMergin, b + crossMergin) + lwhite p q = expand . Singleton $ Line' white 4 p q + +-- GET USER + +{-# ANN getUser ("HLint: ignore Redundant <$>" :: String) #-} + +getUser :: LockId -> ReactF s (Png, T.Text, T.Text) +getUser lck = ex3 . toHashMap <$> getObj1 lck >>= err `either` \(au, nm, url) -> + getAvatarPng au >>= either err (pure . (, nm, url)) + where + ex3 o = (,,) + <$> ex o "avatar_url" (NoAvatarAddress, "No Avatar Address") + <*> ex o "login" (NoLoginName, "No Login Name") + <*> ex o "html_url" (NoHtmlUrl, "No HTML URL") + ex o k e = case HM.lookup k o of Just (String v) -> Right v; _ -> Left e + err e = adjust (uncurry raiseError e) >> getUser lck + +getAvatarPng :: T.Text -> ReactF s (Either (Error, ErrorMessage) Png) +getAvatarPng url = (<$> adjust (httpGet url)) + $ snd >>> LBS.toStrict >>> convert >>> either + (Left . (NoAvatar ,)) + (Right . Png avatarSizeX avatarSizeY) + +convert :: BS.ByteString -> Either String BS.ByteString +convert img = LBS.toStrict . P.encodePng . P.convertRGB8 <$> P.decodeImage img + +-- GET OBJECT + +getObj1 :: LockId -> ReactF s Object +getObj1 lck = withLock lck $ adjust loadJsons >>= \case + [] -> getObj1FromWeb + o : os -> o <$ adjust (storeJsons os) + +getObj1FromWeb :: ReactF s Object +getObj1FromWeb = getObjs >>= \case + Right (o : os) -> o <$ adjust (storeJsons os) + Right [] -> adjust (raiseError EmptyJson "Empty JSON") >> getObj1FromWeb + Left em -> adjust (raiseError NotJson em) >> getObj1FromWeb + +getObjs :: ReactF s (Either String [Object]) +getObjs = do + n <- adjust $ getRandomR (0, userPageMax) + (hdr, bdy) <- adjust . httpGet $ api n + case (rmng hdr, rst hdr) of + (Just rmn, _) | rmn > (0 :: Int) -> pure $ eitherDecode bdy + (Just _, Just t) -> + adjust (beginSleep t) >> adjust endSleep >> getObjs + (Just _, Nothing) -> adjust (uncurry raiseError rstE) >> getObjs + (Nothing, _) -> adjust (uncurry raiseError rmngE) >> getObjs + where + api = ("https://api.github.com/users?since=" <>) . T.pack . show @Int + rmng = (read . BSC.unpack <$>) . lookup "X-RateLimit-Remaining" + rst = posixSeconds <=< lookup "X-RateLimit-Reset" + rmngE = (NoRateLimitRemaining, "No X-RateLimit-Remaining header") + rstE = (NoRateLimitReset, "No X-RateLimit-Reset header") + posixSeconds = (posixSecondsToUTCTime . fromInteger <$>) + . readMaybe . BSC.unpack diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"