I am currently writing a game using gloss' play. The basic structure of this game is very simple: I have a board with units on it, one of which is in focus.
I have added the ability to change the focus by cycling through the units on the board using KeyTab. Quite quickly, I realised that I wanted to also be able to cycle back so I thought I'd use Shift + KeyTab to do so as is customary in this situation.
gloss' Events come with Modifiers, one of which is shift. Perfect? Well... not quite: whenever I press Shift + KeyTab, the event is never received by the window (I used Debug.Trace's trace to print all the received Events).
With CAPS LOCK, I do receive KeyTab with the shift modifier marked as Down. If I switch to using Ctrl + KeyTab as my shortcut, it works perfectly well. Here is a minimal example reproducing the problem:
module Main where
import Graphics.Gloss
import Graphics.Gloss.Interface.Pure.Game
data Board = Board Color Color Color
forward :: Board -> Board
forward (Board x y z) = Board y z x
backward :: Board -> Board
backward (Board x y z) = Board z x y
displayPoint :: Point -> Color -> Picture
displayPoint (x, y) c = translate x y $ color c $ circle 10
displayBoard :: Board -> Picture
displayBoard (Board x y z) =
Pictures $ zipWith displayPoint coordinates [x, y, z]
where coordinates = [(0, 30), (-30, -30), (30, -30)]
react :: Event -> Board -> Board
react (EventKey (SpecialKey KeyTab) Down mods _) b =
case shift mods of
Up -> forward b
Down -> backward b
react _ b = b
main :: IO ()
main =
let window = InWindow "Buggy" (100, 100) (200, 200)
board = Board blue red yellow
in play window black 24 board displayBoard react (const id)
Related
I am just started haskell gloss. I learnt a little about it functions. I am trying to draw a chess board in haskell. The main problem is that everything is being drawn in the center. If I used the function translate the board is being draw at random position. That's probably because translate moves from moves the distance given from current position not to the exact point which is given.
Is there a way in gloss haskell so that we can move to a specific point like setTransform or translateTo. Or is there any function which tells coordinates of current point at which we are at.
module Main where
import Graphics.Gloss
import Lib (someFunc)
blockSize :: Float
blockSize = 50
board :: [[Int]]
board = replicate 8 (replicate 8 0)
drawTile :: Float -> Float -> Color -> Picture
drawTile a b col = translate a b $ color col $ rectangleSolid blockSize blockSize
-- drawRow :: Int -> Pictur
-- drawRow =
toInt :: Float -> Integer
toInt = round
getColor :: Float -> Float -> Color
getColor i j = if even $ toInt ((i * 8) + j) then red else blue
screenHeight = 700
screenWidth = 1000
drawing :: Picture
drawing = pictures [drawTile (row * blockSize) (e * blockSize) (getColor row e) | row <- [0 .. 8], e <- [0 .. 8]]
-- moveToStart = viewPortTranslate
main :: IO ()
main = display (InWindow (show board) (screenWidth, screenHeight) (10, 10)) white (translate 0 0 drawing)
Edit: I don't want to fix this specific problem by using some math tricks. What I want to know is that how can I translate to a specfic position. Like when I do someFunc 0 0 the position should go to 0 0 top right corner.
If its not possible please tell the way to get the current transform point.
There is no existing Gloss function that will take an arbitrary picture and move it so its top-left corner is in the top-left corner of the screen. All existing transformation functions in Gloss are relative, so there's no way to make an "absolute" move to a specific point.
The best you can probably do is arrange to draw your picture so its origin matches its top-left corner, and then translate it up and left by half the screen height and width.
import Graphics.Gloss
-- chess board with top-left corner at (0,0), one unit in width and height
chess = scale (1/8) (1/8) $ pictures [square x y | x <- [0..7], y <- [0..8]]
where square x y =
Color (if even (x+y) then red else black) $
translate (fromIntegral x+0.5) (-fromIntegral y -0.5) $ rectangleSolid 1 1
main = display (InWindow "Layout" (1000,700) (10,10)) white $
-- scale to a 700x700 square (with origin still at top-level corner)
-- then translate origin from default position at center of window
-- to top-left corner, by moving half the window width and height
translate (-500) 350 $ scale 700 700 chess
I'm trying to make what I think is called an Ulam spiral using Haskell.
It needs to go outwards in a clockwise rotation:
6 - 7 - 8 - 9
| |
5 0 - 1 10
| | |
4 - 3 - 2 11
|
..15- 14- 13- 12
For each step I'm trying to create coordinates, the function would be given a number and return spiral coordinates to the length of input number eg:
mkSpiral 9
> [(0,0),(1,0),(1,-1),(0,-1),(-1,-1),(-1,0),(-1,1),(0,1),(1,1)]
(-1, 1) - (0, 1) - (1, 1)
|
(-1, 0) (0, 0) - (1, 0)
| |
(-1,-1) - (0,-1) - (1,-1)
I've seen Looping in a spiral solution, but this goes counter-clockwise and it's inputs need to the size of the matrix.
I also found this code which does what I need but it seems to go counterclock-wise, stepping up rather than stepping right then clockwise :(
type Spiral = Int
type Coordinate = (Int, Int)
-- number of squares on each side of the spiral
sideSquares :: Spiral -> Int
sideSquares sp = (sp * 2) - 1
-- the coordinates for all squares in the given spiral
coordinatesForSpiral :: Spiral -> [Coordinate]
coordinatesForSpiral 1 = [(0, 0)]
coordinatesForSpiral sp = [(0, 0)] ++ right ++ top ++ left ++ bottom
where fixed = sp - 1
sides = sideSquares sp - 1
right = [(x, y) | x <- [fixed], y <- take sides [-1*(fixed-1)..]]
top = [(x, y) | x <- reverse (take sides [-1*fixed..]), y <- [fixed]]
left = [(x, y) | x <- [-1*fixed], y <- reverse(take sides [-1*fixed..])]
bottom = [(x, y) | x <- take sides [-1*fixed+1..], y <- [-1*fixed]]
-- an endless list of coordinates (the complete spiral)
mkSpiral :: Int -> [Coordinate]
mkSpiral x = take x endlessSpiral
endlessSpiral :: [Coordinate]
endlessSpiral = endlessSpiral' 1
endlessSpiral' start = coordinatesForSpiral start ++ endlessSpiral' (start + 1)
After much experimentation I can't seem to change the rotation or starting step direction, could someone point me in the right way or a solution that doesn't use list comprehension as I find them tricky to decode?
Let us first take a look at how the directions of a spiral are looking:
R D L L U U R R R D D D L L L L U U U U ....
We can split this in sequences like:
n times n+1 times
_^_ __^__
/ \ / \
R … R D … D L L … L U U … U
\_ _/ \__ __/
v v
n times n+1 times
We can repeat that, each time incrementing n by two, like:
data Dir = R | D | L | U
spiralSeq :: Int -> [Dir]
spiralSeq n = rn R ++ rn D ++ rn1 L ++ rn1 U
where rn = replicate n
rn1 = replicate (n + 1)
spiral :: [Dir]
spiral = concatMap spiralSeq [1, 3..]
Now we can use Dir here to calculate the next coordinate, like:
move :: (Int, Int) -> Dir -> (Int, Int)
move (x, y) = go
where go R = (x+1, y)
go D = (x, y-1)
go L = (x-1, y)
go U = (x, y+1)
We can use scanl :: (a -> b -> a) -> a -> [b] -> [a] to generate the points, like:
spiralPos :: [(Int, Int)]
spiralPos = scanl move (0,0) spiral
This will yield an infinite list of coordinates for the clockwise spiral. We can use take :: Int -> [a] -> [a] to take the first k items:
Prelude> take 9 spiralPos
[(0,0),(1,0),(1,-1),(0,-1),(-1,-1),(-1,0),(-1,1),(0,1),(1,1)]
The idea with the following solution is that instead of trying to generate the coordinates directly, we’ll look at the directions from one point to the next. If you do that, you’ll notice that starting from the first point, we go 1× right, 1× down, 2× left, 2× up, 3× right, 3× down, 4× left… These can then be seperated into the direction and the number of times repeated:
direction: > v < ^ > v < …
# reps: 1 1 2 2 3 3 4 …
And this actually gives us two really straightforward patterns! The directions just rotate > to v to < to ^ to >, while the # of reps goes up by 1 every 2 times. Once we’ve made two infinite lists with these patterns, they can be combined together to get an overall list of directions >v<<^^>>>vvv<<<<…, which can then be iterated over to get the coordinate values.
Now, I’ve always thought that just giving someone a bunch of code as the solution is not the best way to learn, so I would highly encourage you to try implementing the above idea yourself before looking at my solution below.
Welcome back (if you did try to implement it yourself). Now: onto my own solution. First I define a Stream data type for an infinite stream:
data Stream a = Stream a (Stream a) deriving (Show)
Strictly speaking, I don’t need streams for this; Haskell’s predefined lists are perfectly adequate for this task. But I happen to like streams, and they make some of the pattern matching a bit easier (because I don’t have to deal with the empty list).
Next, I define a type for directions, as well as a function specifying how they interact with points:
-- Note: I can’t use plain Left and Right
-- since they conflict with constructors
-- of the ‘Either’ data type
data Dir = LeftDir | RightDir | Up | Down deriving (Show)
type Point = (Int, Int)
move :: Dir -> Point -> Point
move LeftDir (x,y) = (x-1,y)
move RightDir (x,y) = (x+1, y)
move Up (x,y) = (x,y+1)
move Down (x,y) = (x,y-1)
Now I go on to the problem itself. I’ll define two streams — one for the directions, and one for the number of repetitions of each direction:
dirStream :: Stream Dir
dirStream = Stream RightDir $ Stream Down $ Stream LeftDir $ Stream Up dirVals
numRepsStream :: Stream Int
numRepsStream = go 1
where
go n = Stream n $ Stream n $ go (n+1)
At this point we’ll need a function for replicating each element of a stream a specific number of times:
replicateS :: Stream Int -> Stream a -> Stream a
replicateS (Stream n ns) (Stream a as) = conss (replicate n a) $ replicateS ns as
where
-- add more than one element to the beginning of a stream
conss :: [a] -> Stream a -> Stream a
conss [] s = s
conss (x:xs) s = Stream x $ appends xs s
This gives replicateS dirStream numRepsStream for the stream of directions. Now we just need a function to convert those directions to coordinates, and we’ve solved the problem:
integrate :: Stream Dir -> Stream Point
integrate = go (0,0)
where
go p (Stream d ds) = Stream p (go (move d p) ds)
spiral :: Stream Point
spiral = integrate $ replicateS numRepsStream dirStream
Unfortunately, it’s somewhat inconvenient to print an infinite stream, so the following function is useful for debugging and printing purposes:
takeS :: Int -> Stream a -> [a]
takeS 0 _ = []; takeS n (Stream x xs) = x : (takeS (n-1) xs)
I'm trying to implement an algorithm of de-convolution in Haskell and couldn't find a simpler one than Richardson Lucy. I looked up at the existing matlab/python implementation but am unable to understand from where to start or how exactly to implement.
The library I want to use is https://github.com/lehins/hip.
If someone can provide an outline of some implementation or some general idea about the functions with some code snippets, that would be very helpful to me.
Thanks in advance!
The algorithm is actually pretty straightforward. Using the notation on the Wikipedia page for Richardson-Lucy deconvolution, if an underlying image u0 was convolved by a kernel p to produce an observed image d, then you can iterate the function:
deconvolve p d u = u * conv (transpose p) (d / conv p u)
over u with an initial starting estimate (of d, for example) to get a progressively better estimate of u0.
In HIP, the actual one-step deconvolve function might look like:
deconvolve :: Image VS X Double
-> Image VS RGB Double
-> Image VS RGB Double
-> Image VS RGB Double
deconvolve p d u
= u * conv (transpose p) (d / conv p u)
where conv = convolve Edge
and you could use something like this:
let us = iterate (deconvolve p d) d
u10 = us !! 10 -- ten iterations
An example of a full program is:
import Graphics.Image as I
import Graphics.Image.Interface as I
import Prelude as P
blur :: Image VS X Double
blur = blur' / scalar (I.sum blur')
where blur' = fromLists [[0,0,4,3,2]
,[0,1,3,4,3]
,[1,2,3,3,4]
,[0,1,2,1,0]
,[0,0,1,0,0]]
deconvolve :: Image VS X Double
-> Image VS RGB Double
-> Image VS RGB Double
-> Image VS RGB Double
deconvolve p d u
= u * conv (transpose p) (d / conv p u)
where conv = convolve Edge
main :: IO ()
main = do
-- original underlying image
u0 <- readImage' "images/frog.jpg" :: IO (Image VS RGB Double)
-- the kernel
let p = blur
-- blurred imaged
let d = convolve Edge p u0
-- iterative deconvolution
let us = iterate (deconvolve p d) d
u1 = us !! 1 -- one iteration
u2 = us !! 20 -- twenty iterations
let output = makeImage (rows u0, cols u0 * 4)
(\(r,c) ->
let (i, c') = c `quotRem` cols u0
in index ([u0,d,u1,u2] !! i) (r,c'))
:: Image VS RGB Double
writeImage "output.jpg" output
which generates the following image of (left-to-right) the original frog, the blurred frog, a one-fold deconvolution, and a twenty-fold deconvolution.
Given the following:
integralB :: Num a => Behavior t a -> Behavior t a -- definite integral of a behaviour
eJump :: Event t a -- tells the player to jump
bYAccel = pure 4000 -- y acceleration
bYVel = integralB bYAccel -- y velocity
bY = integralB bYVel -- y position
How do I make the player jump (probably by setting its y velocity) when a jump event arrives?
You'll need to be able to apply an impulse to the Y velocity for the jump. From your own answer, you've come up with a way to do so by summing all the impulses from the jumps and adding them to the integral of the acceleration.
Your acceleration is also constant. If you don't want the player falling constantly, you'd need something like:
bYAccel = (ifB airborne) 4000 0
airborne = fmap (>0) bY
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
One possible reason the height of your jumps varies is you aren't resetting the velocity when the player lands. If you have rules that hold the player above some position (like the floor), and are somehow stopping acceleration when the player hits the floor, you will also need to set the velocity to 0 if it is in the direction of the floor. (If you also set it to 0 when it's not in the direction of the floor, the player can never get the velocity to leave the ground.)
The reason this would cause erratic jumping heights is that the final velocity when the player lands will be close to the impulse you applied for them to take off. Using your numbers, if a jump started with a velocity of -5000, and ended with a velocity of 4800, the next jump will add an impulse of -5000, taking the jump to a starting velocity of only -200. That might have an ending velocity of 300, so the next jump will be an almost full -4700 jump.
Here's a complete working example. It uses the gloss library for input and display. The gameDefinition corresponds to the components introduced in your question. integrateDeltas is equivalent to your integralB, but produces events that are impulses, which are easy to generate in a clocked framework like gloss, and easy to use mixed with other events that cause impulses, like jumping.
{-# LANGUAGE RankNTypes #-}
module Main where
import Reactive.Banana
import Reactive.Banana.Frameworks.AddHandler
import Reactive.Banana.Frameworks
import Data.IORef
import qualified Graphics.Gloss.Interface.IO.Game as Gloss
gameDefinition :: GlossGameEvents t -> Behavior t Gloss.Picture
gameDefinition events = renderBehavior
where
bY = accumB 0 (fmap sumIfPositive yShifts)
yShifts = integrateDeltas bYVel
bYVel = accumB 0 yVelChanges
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
yVelShifts = union (integrateDeltas bYAccel) (fmap (const 3) eJump)
bYAccel = (ifB airborne) (-10) 0
airborne = fmap (>0) bY
eJump = filterE isKeyEvent (event events)
integrateDeltas = integrateDeltaByTimeStep (timeStep events)
renderBehavior = (liftA3 render) bY bYVel bYAccel
render y yVel yAccel =
Gloss.Pictures [
Gloss.Translate 0 (20+y*100) (Gloss.Circle 20),
Gloss.Translate (-50) (-20) (readableText (show y)),
Gloss.Translate (-50) (-40) (readableText (show yVel)),
Gloss.Translate (-50) (-60) (readableText (show yAccel))
]
readableText = (Gloss.Scale 0.1 0.1) . Gloss.Text
-- Utilities
sumIfPositive :: (Ord n, Num n) => n -> n -> n
sumIfPositive x y = max 0 (x + y)
ifB :: Behavior t Bool -> a -> a -> Behavior t a
ifB boolBehavior yes no = fmap (\bool -> if bool then yes else no) boolBehavior
integrateDeltaByTimeStep :: (Num n) => Event t n -> Behavior t n -> Event t n
integrateDeltaByTimeStep timeStep derivative = apply (fmap (*) derivative) timeStep
isKeyEvent :: Gloss.Event -> Bool
isKeyEvent (Gloss.EventKey _ _ _ _) = True
isKeyEvent _ = False
-- Main loop to run it
main :: IO ()
main = do
reactiveGame (Gloss.InWindow "Reactive Game Example" (400, 400) (10, 10))
Gloss.white
100
gameDefinition
-- Reactive gloss game
data GlossGameEvents t = GlossGameEvents {
event :: Event t Gloss.Event,
timeStep :: Event t Float
}
makeReactiveGameNetwork :: Frameworks t
=> IORef Gloss.Picture
-> AddHandler Gloss.Event
-> AddHandler Float
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> Moment t ()
makeReactiveGameNetwork latestFrame glossEvent glossTime game = do
eventEvent <- fromAddHandler glossEvent
timeStepEvent <- fromAddHandler glossTime
let
events = GlossGameEvents { event = eventEvent, timeStep = timeStepEvent }
pictureBehavior = game events
pictureChanges <- changes pictureBehavior
reactimate (fmap (writeIORef latestFrame) pictureChanges)
reactiveGame :: Gloss.Display
-> Gloss.Color
-> Int
-> (forall t. GlossGameEvents t -> Behavior t Gloss.Picture)
-> IO ()
reactiveGame display color steps game = do
latestFrame <- newIORef Gloss.Blank
(glossEvent, fireGlossEvent) <- newAddHandler
(glossTime, addGlossTime) <- newAddHandler
network <- compile (makeReactiveGameNetwork latestFrame glossEvent glossTime game)
actuate network
Gloss.playIO
display
color
steps
()
(\world -> readIORef latestFrame)
(\event world -> fireGlossEvent event)
(\time world -> addGlossTime time)
In this example, bY checks for collision with a floor at 0 by accumulating the impulses, but constraining the accumulated value to be above 0.
The velocity, bYVel, accumulates all impulses while airborne, but only those impulses that are directed away from the floor while not airborne. If you change
yVelChanges = apply ((ifB airborne) (+) sumIfPositive) yVelShifts
to
yVelChanges = fmap (+) yVelShifts
it recreates the erratic jumping bug.
The acceleration, bYAccel, is only present while airborne.
I used a coordinate system with a +Y axis in the up direction (opposite the acceleration).
The code at the end is a small framework to hook reactive-banana up to gloss.
Solved it! I feel a little silly for not thinking of this earlier, but I just increment a counter every eJump and add that counter on to bYVel.
bJumpVel = sumB $ (-5000) <$ eJump
bYVel = (+) <$> bJumpVel <*> integralB bYAccel
-- gives the sum of the events
sumB :: Num a => Event t a -> Behavior t a
sumB e = accumB 0 $ (+) <$> e
For some reason the height of the jump always varies quite a bit, but that's probably an unrelated problem to do with my timing of things.
I won't mark this question as answered yet in case someone wants to share a better one.
I'm trying to simulate a bouncing ball with the Yampa-Framework: Given an initial x-position, height and velocity, the ball should bounce according to gravity rules. The signal function takes a "Tip-Event" as input, the idea being "when the ball is tipped, it's speed should double".
The ball bounces nicely, but every time there is a tipping event, the function goes in to an endless loop. I figured I probably need to add a delay (dSwitch, pre, notYet?), but I do not know how. Any help would be appreciated!
{-# LANGUAGE Arrows #-}
module Ball where
import FRP.Yampa
type Position = Double
type Velocity = Double
type Height = Double
data Ball = Ball {
height :: Height,
width :: Position,
vel :: Velocity
} deriving (Show)
type Tip = Event ()
fly :: Position -> (Height, Velocity) -> SF Tip (Ball, Event (Height,Velocity))
fly w0 (h0, v0) = proc tipEvent -> do
let tip = (tipEvent == Event ())
v <- (v0+) ^<< integral -< -10.0
h <- (h0+) ^<< integral -< v
returnA -< (Ball h w0 v,
if h < 0 then Event (0,(-v*0.6))
else if tip then Event (h, (v*2))
else NoEvent)
bounce w (h,v) = switch (fly w (h,v)) (bounce w)
runBounce w (h,v) = embed (bounce 10 (100.0, 10.0)) (deltaEncode 0.1 [NoEvent, NoEvent, NoEvent, Event (), NoEvent])
EDIT: I managed to avoid the endless loop by feeding back a flag when a tip occurred, but that still does not feel like the right way to do it...
fly :: Position -> (Height, Velocity, Bool) -> SF Tip (Ball, Event (Height,Velocity,Bool))
fly w0 (h0, v0, alreadyTipped) = proc tipEvent -> do
let tip = tipEvent == Event () && (not alreadyTipped)
v <- (v0+) ^<< integral -< -10.0
h <- (h0+) ^<< integral -< v
returnA -< (Ball h w0 v,
if h < 0 then Event (0,(-v*0.6), False)
else if tip then Event (h, (v*2), True)
else NoEvent)
bounce w (h,v,alreadyTipped) = switch (fly w (h,v,alreadyTipped)) (bounce w)
After a few days hacking I think I found the answer. The trick is to use notYet to delay the switching event to the next point in time, so that the switching (and hence the recursive call to fly) occurs when the "old" tipping event is gone. The second function makes sure that only the second part of the result tuple (Ball, Event (..)) will be put through notYet. This removes the endless loop, but also changes the semantics: The switching now takes place one "time step" later, this in turn leads to a different speed.
This Yampa thing is actually quite nice, sadly there is not much documentation to find. I still could not find out what the pre and iPre functions are good for, I figure they can be used in a similar context.
fly :: Position -> (Height, Velocity) -> SF Tip (Ball, Event (Height,Velocity))
fly w0 (h0, v0) = proc tipEvent -> do
let tip = tipEvent == Event ()
v <- (v0+) ^<< integral -< -10.0
h <- (h0+) ^<< integral -< v
returnA -< (Ball h w0 v,
if h < 0 then Event (0,-v*0.6)
else if tip then Event (h, v*2)
else NoEvent)
bounce w (h,v) = switch (fly w (h,v) >>> second notYet) (bounce w)