<commit_before>{-# LANGUAGE OverloadedStrings, RecursiveDo #-}
module Main where
import           Data.Bits hiding (rotate)
import qualified Data.Set as S
import           NanoVG as NVG
import           Prelude hiding (init)
import           Graphics.UI.GLFW as GLFW hiding (Image)
import           Control.Monad
import           Control.Monad.Loops
import           Control.Monad.Trans.Maybe
import           Control.Monad.Fix
import           Graphics.GL.Core32
import           System.Exit ( exitWith, ExitCode(..) )
import           Reactive.Banana as R
import           Reactive.Banana.Frameworks
import           Reactive.Banana.GLFW as RGLFW

import           Foreign.C.Types
import           Foreign.Ptr

foreign import ccall unsafe "initGlew"
  glewInit :: IO CInt

type Point = (CFloat, CFloat)
type PointB = Behavior Point
type BoolB = Behavior Bool
type RealB = Behavior CFloat

type CPoint = (PointB, BoolB)
type ImageB = Behavior (IO ())

toPoint :: (Double, Double) -> Point
toPoint (x,y) = (realToFrac x, realToFrac y)

isPress :: MouseButton -> MouseEvent -> Bool
isPress mb e = press e && (mouseButton e == mb)

isRelease :: MouseButton -> MouseEvent -> Bool
isRelease mb e = release e && (mouseButton e == mb)

isLeftPress :: MouseEvent -> Bool
isLeftPress = isPress MouseButton'1

isLeftRelease :: MouseEvent -> Bool
isLeftRelease = isRelease MouseButton'1

leftMouseReleasePos :: RGLFW.Cursor -> Event MouseEvent -> Event Point
leftMouseReleasePos c e = mouseEventPos c e isLeftRelease

leftMousePressPos :: RGLFW.Cursor -> Event MouseEvent -> Event Point
leftMousePressPos c e = mouseEventPos c e isLeftPress

mouseEventPos :: RGLFW.Cursor -> Event MouseEvent -> (MouseEvent -> Bool) -> Event Point
mouseEventPos cursor mouseE filterPred = toPoint <$> mouseEDouble
  where mouseEDouble = cursorPos cursor <@ mouseClickE
        mouseClickE = filterE filterPred mouseE

cpointUnderMouse :: MonadMoment m => RGLFW.Cursor -> Event MouseEvent -> m CPoint
cpointUnderMouse cursor mouseE = do
  mouseDownB <- stepper False (press <$> mouseE)
  return $ (toPoint <$> cursorPos cursor, mouseDownB)

cpointReleased :: MonadMoment m => RGLFW.Cursor -> Event MouseEvent -> m CPoint
cpointReleased cursor mouseE = do
  let initialPos = (10.0, 10.0)
  posB <- stepper initialPos (leftMouseReleasePos cursor mouseE)
  return $ (posB, pure False)

isNear :: Point -> Point -> Bool
isNear (x1,y1) (x2,y2) = (abs (x2 - x1) < 10) && (abs (y2 - y1) < 10)

cursorPos' :: RGLFW.Cursor -> PointB
cursorPos' c = toPoint <$> cursorPos c

editCPoint :: MonadMoment m => RGLFW.Cursor -> Event MouseEvent -> m CPoint
editCPoint cursor mouseE = do
  (idlePosB, idleExB) <- cpointReleased cursor mouseE
  (pressedPosB, pressedExB) <- cpointUnderMouse cursor mouseE
  --let mousePressE = isLeftPress <$> mouseE
  let mouseNearPointPosE = (isNear <$> idlePosB) <@> (mouseEventPos cursor mouseE (const True))
  editPosB <- switchB idlePosB $ (\near -> if near then pressedPosB else idlePosB) <$> mouseNearPointPosE
  editExB <- switchB idleExB $ (\near -> if near then pressedExB else idleExB) <$> mouseNearPointPosE
  return (editPosB, editExB)

editCPoint' :: (MonadMoment m, MonadFix m) => RGLFW.Cursor -> Event MouseEvent -> m BoolB
editCPoint' cursor mouseE = mdo
  grabB <- stepper False grabbingE
  let closeEnough = (<) <$> distance2 pointPos (cursorPos' cursor) <*> grabDistance
      grabE = const () <$> whenE closeEnough (filterE isLeftPress mouseE)
      releaseE = const () <$> whenE grabB (filterE isLeftRelease mouseE)
      grabbingE = unionWith (\v1 v2 -> v2) (const True <$> grabE) (const False <$> releaseE)
  return grabB

pointPos :: PointB
pointPos = undefined

grabDistance :: RealB
grabDistance = (2 *) <$> pointSize

distance2 :: PointB -> PointB -> RealB
distance2 = liftA2 distance
  where distance (x1, y1) (x2, y2) = sqrt ((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))

pointSize :: RealB
pointSize = pure 8

main :: IO ()
main = do
  e <- init
  when (not e) $ putStrLn "Failed to init GLFW"
  windowHint $ WindowHint'ContextVersionMajor 2
  windowHint $ WindowHint'ContextVersionMinor 1
  win <- createWindow 800 600 "NanoVG" Nothing Nothing
  case win of
    Nothing -> putStrLn "Failed to create window" >> terminate
    Just w ->
      do makeContextCurrent win
         glewInit
         glGetError
         -- createGL2 is a function from a local nanovg fork (also on my github) modified
         -- to run on GL2 instead of upstream version which runs on GL3
         c@(Context c') <- createGL2 (S.fromList [Antialias,StencilStrokes,Debug])
         -- error handling? who needs that anyway
         Just staticData <- runMaybeT $ loadStaticData c
         swapInterval 0
         setTime 0

         (displayHandler, runDisplay) <- newAddHandler

         h <- windowHandler w
         network <- compile $ do
           displayE <- fromAddHandler displayHandler
           keyE <- keyEvent h
           mouseE <- mouseEvent h
           closeE <- close h
           cursor <- cursor h TopLeft
           cpoint <- editCPoint cursor mouseE
           reactimate $ renderCPoint c cpoint <@ displayE
           reactimate $ shutdown w <$ filterE (match Key'Escape) keyE
           reactimate $ shutdown w <$ closeE
           reactimate $ print <$> keyE
           reactimate $ print <$> mouseE
           reactimate $ print . ("Released " ++ ) . show <$> leftMouseReleasePos cursor mouseE
         actuate network<commit_msg>finish editCPoint, but it doesn't work right (yet?)<commit_after>{-# LANGUAGE OverloadedStrings, RecursiveDo #-}
module Main where
import           Data.Bits hiding (rotate)
import qualified Data.Set as S
import           NanoVG as NVG
import           Prelude hiding (init)
import           Graphics.UI.GLFW as GLFW hiding (Image)
import           Control.Monad
import           Control.Monad.Loops
import           Control.Monad.Trans.Maybe
import           Control.Monad.Fix
import           Graphics.GL.Core32
import           System.Exit ( exitWith, ExitCode(..) )
import           Reactive.Banana as R
import           Reactive.Banana.Frameworks
import           Reactive.Banana.GLFW as RGLFW

import           Foreign.C.Types
import           Foreign.Ptr

foreign import ccall unsafe "initGlew"
  glewInit :: IO CInt

type Point = (CFloat, CFloat)
type PointB = Behavior Point
type BoolB = Behavior Bool
type RealB = Behavior CFloat

type CPoint = (PointB, BoolB)
type ImageB = Behavior (IO ())

toPoint :: (Double, Double) -> Point
toPoint (x,y) = (realToFrac x, realToFrac y)

isPress :: MouseButton -> MouseEvent -> Bool
isPress mb e = press e && (mouseButton e == mb)

isRelease :: MouseButton -> MouseEvent -> Bool
isRelease mb e = release e && (mouseButton e == mb)

isLeftPress :: MouseEvent -> Bool
isLeftPress = isPress MouseButton'1

isLeftRelease :: MouseEvent -> Bool
isLeftRelease = isRelease MouseButton'1

leftMouseReleasePos :: RGLFW.Cursor -> Event MouseEvent -> Event Point
leftMouseReleasePos c e = mouseEventPos c e isLeftRelease

leftMousePressPos :: RGLFW.Cursor -> Event MouseEvent -> Event Point
leftMousePressPos c e = mouseEventPos c e isLeftPress

mouseEventPos :: RGLFW.Cursor -> Event MouseEvent -> (MouseEvent -> Bool) -> Event Point
mouseEventPos cursor mouseE filterPred = toPoint <$> mouseEDouble
  where mouseEDouble = cursorPos cursor <@ mouseClickE
        mouseClickE = filterE filterPred mouseE

cpointUnderMouse :: MonadMoment m => RGLFW.Cursor -> Event MouseEvent -> m CPoint
cpointUnderMouse cursor mouseE = do
  mouseDownB <- stepper False (press <$> mouseE)
  return $ (toPoint <$> cursorPos cursor, mouseDownB)

cpointReleased :: MonadMoment m => RGLFW.Cursor -> Event MouseEvent -> m CPoint
cpointReleased cursor mouseE = do
  let initialPos = (10.0, 10.0)
  posB <- stepper initialPos (leftMouseReleasePos cursor mouseE)
  return $ (posB, pure False)

isNear :: Point -> Point -> Bool
isNear (x1,y1) (x2,y2) = (abs (x2 - x1) < 10) && (abs (y2 - y1) < 10)

cursorPos' :: RGLFW.Cursor -> PointB
cursorPos' c = toPoint <$> cursorPos c

editCPoint :: MonadMoment m => RGLFW.Cursor -> Event MouseEvent -> m CPoint
editCPoint cursor mouseE = do
  (idlePosB, idleExB) <- cpointReleased cursor mouseE
  (pressedPosB, pressedExB) <- cpointUnderMouse cursor mouseE
  --let mousePressE = isLeftPress <$> mouseE
  let mouseNearPointPosE = (isNear <$> idlePosB) <@> (mouseEventPos cursor mouseE (const True))
  editPosB <- switchB idlePosB $ (\near -> if near then pressedPosB else idlePosB) <$> mouseNearPointPosE
  editExB <- switchB idleExB $ (\near -> if near then pressedExB else idleExB) <$> mouseNearPointPosE
  return (editPosB, editExB)

editCPoint' :: (MonadMoment m, MonadFix m) => Point -> RGLFW.Cursor -> Event MouseEvent -> m CPoint
editCPoint' p0 cursor mouseE = mdo
  pointPos <- ifB mouseE grabB (cursorPos' cursor) lastRelease
  grabB <- stepper False grabbingE
  lastRelease <- stepper p0 (pointPos <@ releaseE)
  let closeEnough = (<) <$> distance2 pointPos (cursorPos' cursor) <*> grabDistance
      grabE = const True <$> whenE closeEnough (filterE isLeftPress mouseE)
      releaseE = const False <$> whenE grabB (filterE isLeftRelease mouseE)
      grabbingE = unionWith (\v1 v2 -> v1) grabE releaseE
  return (pointPos, closeEnough)

ifB :: MonadMoment m => Event b -> BoolB -> Behavior a -> Behavior a -> m (Behavior a)
ifB trigger condB b1 b2 = switchB b2 (switcherB <@ trigger)
  where switcherB = (\x -> if x then b1 else b2) <$> condB

grabDistance :: RealB
grabDistance = (2 *) <$> pointSize

distance2 :: PointB -> PointB -> RealB
distance2 = liftA2 distance
  where distance (x1, y1) (x2, y2) = sqrt ((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))

pointSize :: RealB
pointSize = pure 8

main :: IO ()
main = do
  e <- init
  when (not e) $ putStrLn "Failed to init GLFW"
  windowHint $ WindowHint'ContextVersionMajor 2
  windowHint $ WindowHint'ContextVersionMinor 1
  win <- createWindow 800 600 "NanoVG" Nothing Nothing
  case win of
    Nothing -> putStrLn "Failed to create window" >> terminate
    Just w ->
      do makeContextCurrent win
         glewInit
         glGetError
         -- createGL2 is a function from a local nanovg fork (also on my github) modified
         -- to run on GL2 instead of upstream version which runs on GL3
         c@(Context c') <- createGL2 (S.fromList [Antialias,StencilStrokes,Debug])
         -- error handling? who needs that anyway
         Just staticData <- runMaybeT $ loadStaticData c
         swapInterval 0
         setTime 0

         (displayHandler, runDisplay) <- newAddHandler

         h <- windowHandler w
         network <- compile $ do
           displayE <- fromAddHandler displayHandler
           keyE <- keyEvent h
           mouseE <- mouseEvent h
           closeE <- close h
           cursor <- cursor h TopLeft
           cpoint <- editCPoint' (50.0, 50.0) cursor mouseE
           reactimate $ renderCPoint c cpoint <@ displayE
           reactimate $ shutdown w <$ filterE (match Key'Escape) keyE
           reactimate $ shutdown w <$ closeE
           reactimate $ print <$> keyE
           reactimate $ print <$> mouseE
           reactimate $ print . ("Released " ++ ) . show <$> leftMouseReleasePos cursor mouseE
         actuate network
{'fraction_non_alphanumeric': 0.09588188205994841, 'fraction_numerical': 0.011295917459752735, 'mean_word_length': 3.0228980322003576, 'pattern_counts': {'":': 0, '<': 98, '<?xml version=': 0, '>': 125, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3159680', 'n_tokens_mistral': 3614, 'n_tokens_neox': 3451, 'n_words': 1157}