Haskell

Fonturi; Pixeli; Imagini

Posted by Feroviarul on
Haskell Logo
Cod Sursa Haskell
{-
DrawF.hs (adapted from drawf.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Draws the bitmapped letter F on the screen (several times).
This demonstrates use of the bitmap call.
-}
import Foreign ( Ptr, newArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
myInit :: IO (Ptr GLubyte)
myInit = do
rowAlignment Unpack $= 1
clearColor $= Color4 0 0 0 0
newArray [
0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00,
0xff, 0x00, 0xff, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0xc0, 0x00,
0xff, 0xc0, 0xff, 0xc0 ]
display :: Ptr GLubyte -> DisplayCallback
display rasters = do
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
color3f (Color3 1 1 1)
rasterPos2i (Vertex2 20 20)
sequence_ $ replicate 3 $
bitmap (Size 10 12) (Vertex2 0 0) (Vector2 11 0) rasters
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1
matrixMode $= Modelview 0
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
— Main Loop
— Open window with initial window size, title bar,
— RGBA display mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 100 100
initialWindowPosition $= Position 100 100
_ <- createWindow progName
rasters <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display rasters
mainLoop
drawF
Haskell Logo
Cod Sursa Haskell
{-
Font.hs (adapted from font.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
Draws some text in a bitmapped font. Uses bitmap and other pixel routines.
Also demonstrates use of display lists.
-}
import Control.Monad ( zipWithM_ )
import Data.List ( genericDrop, genericLength )
import Foreign.C.String ( castCharToCChar )
import Foreign.Marshal.Array ( withArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
space :: [GLubyte]
space = [
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 ]
letters :: [[GLubyte]]
letters = [
[ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0x66, 0x3c, 0x18 ],
[ 0x00, 0x00, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ],
[ 0x00, 0x00, 0x7e, 0xe7, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ],
[ 0x00, 0x00, 0xfc, 0xce, 0xc7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc7, 0xce, 0xfc ],
[ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xc0, 0xff ],
[ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfc, 0xc0, 0xc0, 0xc0, 0xff ],
[ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xcf, 0xc0, 0xc0, 0xc0, 0xc0, 0xe7, 0x7e ],
[ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xff, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],
[ 0x00, 0x00, 0x7e, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x7e ],
[ 0x00, 0x00, 0x7c, 0xee, 0xc6, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06, 0x06 ],
[ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xe0, 0xf0, 0xd8, 0xcc, 0xc6, 0xc3 ],
[ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0 ],
[ 0x00, 0x00, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xdb, 0xff, 0xff, 0xe7, 0xc3 ],
[ 0x00, 0x00, 0xc7, 0xc7, 0xcf, 0xcf, 0xdf, 0xdb, 0xfb, 0xf3, 0xf3, 0xe3, 0xe3 ],
[ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xe7, 0x7e ],
[ 0x00, 0x00, 0xc0, 0xc0, 0xc0, 0xc0, 0xc0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ],
[ 0x00, 0x00, 0x3f, 0x6e, 0xdf, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0x66, 0x3c ],
[ 0x00, 0x00, 0xc3, 0xc6, 0xcc, 0xd8, 0xf0, 0xfe, 0xc7, 0xc3, 0xc3, 0xc7, 0xfe ],
[ 0x00, 0x00, 0x7e, 0xe7, 0x03, 0x03, 0x07, 0x7e, 0xe0, 0xc0, 0xc0, 0xe7, 0x7e ],
[ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0xff ],
[ 0x00, 0x00, 0x7e, 0xe7, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],
[ 0x00, 0x00, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],
[ 0x00, 0x00, 0xc3, 0xe7, 0xff, 0xff, 0xdb, 0xdb, 0xc3, 0xc3, 0xc3, 0xc3, 0xc3 ],
[ 0x00, 0x00, 0xc3, 0x66, 0x66, 0x3c, 0x3c, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ],
[ 0x00, 0x00, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x3c, 0x3c, 0x66, 0x66, 0xc3 ],
[ 0x00, 0x00, 0xff, 0xc0, 0xc0, 0x60, 0x30, 0x7e, 0x0c, 0x06, 0x03, 0x03, 0xff ]]
charToGLubyte :: Char -> GLubyte
charToGLubyte = fromIntegral . castCharToCChar
makeRasterFont :: IO DisplayList
makeRasterFont = do
rowAlignment Unpack $= 1
fontDisplayLists@(fontOffset:_) <- genObjectNames 128
let listsStartingWith ch = genericDrop (charToGLubyte ch) fontDisplayLists
makeLetter dl letter =
defineList dl Compile $
withArray letter $
bitmap (Size 8 13) (Vertex2 0 2) (Vector2 10 0)
zipWithM_ makeLetter (listsStartingWith ‘A’) letters
makeLetter (head (listsStartingWith ‘ ‘)) space
return fontOffset
myInit :: IO DisplayList
myInit = do
shadeModel $= Flat
makeRasterFont
printString :: DisplayList -> String -> IO ()
printString fontOffset s =
preservingAttrib [ ListAttributes ] $ do
listBase $= fontOffset
withArray (map charToGLubyte s) $
callLists (genericLength s) UnsignedByte
— Everything above this line could be in a library
— that defines a font. To make it work, you’ve got
— to call makeRasterFont before you start making
— calls to printString.
display :: DisplayList -> DisplayCallback
display fontOffset = do
let white = Color3 1 1 1
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let color3f = color :: Color3 GLfloat -> IO ()
rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
color3f white
rasterPos2i (Vertex2 20 60)
printString fontOffset “THE QUICK BROWN FOX JUMPS”
rasterPos2i (Vertex2 20 40)
printString fontOffset “OVER A LAZY DOG”
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1
matrixMode $= Modelview 0
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
— Main Loop
— Open window with initial window size, title bar,
— RGBA display mode, and handle input events.
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 300 100
initialWindowPosition $= Position 100 100
_ <- createWindow progName
fontOffset <- myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display fontOffset
mainLoop
font
Haskell Logo
Cod Sursa Haskell
{-
Image.hs (adapted from image.c which is (c) Silicon Graphics, Inc)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
This program demonstrates drawing pixels and shows the effect of
drawPixels, copyPixels, and pixelZoom.
Interaction: moving the mouse while pressing the mouse button will copy
the image in the lower-left corner of the window to the mouse position,
using the current pixel zoom factors. There is no attempt to prevent you
from drawing over the original image. If you press the ‘r’ key, the
original image and zoom factors are reset. If you press the ‘z’ or ‘Z’
keys, you change the zoom factors.
-}
import Data.Bits ( (.&.) )
import Data.IORef ( IORef, newIORef )
import Foreign ( newArray )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
data State = State { zoomFactor :: IORef GLfloat }
makeState :: IO State
makeState = do
z <- newIORef 1
return $ State { zoomFactor = z }
— Create checkerboard image
checkImageSize :: Size
checkImageSize = Size 64 64
type Image = PixelData (Color3 GLubyte)
makeCheckImage :: Size -> GLsizei -> (GLubyte -> (Color3 GLubyte)) -> IO Image
makeCheckImage (Size w h) n f =
fmap (PixelData RGB UnsignedByte) $
newArray [ f c |
i <- [ 0 .. w – 1 ],
j <- [ 0 .. h – 1 ],
let c | (i .&. n) == (j .&. n) = 0
| otherwise = 255 ]
myInit :: IO Image
myInit = do
clearColor $= Color4 0 0 0 0
shadeModel $= Flat
rowAlignment Unpack $= 1
makeCheckImage checkImageSize 0x8 (\c -> Color3 c c c)
display :: Image -> DisplayCallback
display pixelData = do
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
rasterPos2i (Vertex2 0 0)
drawPixels checkImageSize pixelData
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho2D 0 (fromIntegral w) 0 (fromIntegral h)
matrixMode $= Modelview 0
loadIdentity
motion :: State -> MotionCallback
motion state (Position x y) = do
Size _ height <- get windowSize
let screenY = fromIntegral height – y
— resolve overloading, not needed in “real” programs
let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
rasterPos2i (Vertex2 x screenY)
z <- get (zoomFactor state)
pixelZoom $= (z, z)
copyPixels (Position 0 0) checkImageSize CopyColor
pixelZoom $= (1, 1)
flush
resetZoomFactor :: State -> IO ()
resetZoomFactor state = do
zoomFactor state $= 1.0
postRedisplay Nothing
putStrLn “zoomFactor reset to 1.0”
incZoomFactor :: State -> GLfloat -> IO ()
incZoomFactor state inc = do
zoomFactor state $~! (max 0.5 . min 3.0 . (+ inc))
get (zoomFactor state) >>= putStrLn . (“zoomFactor is now ” ++) . show
keyboard :: State -> KeyboardMouseCallback
keyboard state (Char ‘r’) Down _ _ = resetZoomFactor state
keyboard state (Char ‘R’) Down _ _ = resetZoomFactor state
keyboard state (Char ‘z’) Down _ _ = incZoomFactor state 0.5
keyboard state (Char ‘Z’) Down _ _ = incZoomFactor state (-0.5)
keyboard _ (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ _ = return ()
main :: IO ()
main = do
(progName, _args) <- getArgsAndInitialize
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= Size 250 250
initialWindowPosition $= Position 100 100
_ <- createWindow progName
state <- makeState
checkImage <- myInit
displayCallback $= display checkImage
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just (keyboard state)
motionCallback $= Just (motion state)
mainLoop
image
Haskell Logo
Cod Sursa Haskell
{-
ColorMatrix.hs (adapted from colormatrix.c which is (c) Silicon Graphics, Inc.)
Copyright (c) Sven Panne 2002-2005 <svenpanne@gmail.com>
This file is part of HOpenGL and distributed under a BSD-style license
See the file libraries/GLUT/LICENSE
This program uses the color matrix to exchange the color channels of an image.
Red -> Green
Green -> Blue
Blue -> Red
-}
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Graphics.UI.GLUT
import ReadImage
myInit :: IO ()
myInit = do
m <- newMatrix ColumnMajor [ 0, 1, 0, 0,
0, 0, 1, 0,
1, 0, 0, 0,
0, 0, 0, 1 ]
rowAlignment Unpack $= 1
clearColor $= Color4 0 0 0 0
matrixMode $= Color
matrix Nothing $= (m :: GLmatrix GLfloat)
matrixMode $= Modelview 0
display :: Size -> PixelData a -> DisplayCallback
display size pixels = do
clear [ ColorBuffer ]
— resolve overloading, not needed in “real” programs
let rasterPos2i = rasterPos :: Vertex2 GLint -> IO ()
rasterPos2i (Vertex2 1 1)
drawPixels size pixels
flush
reshape :: ReshapeCallback
reshape size@(Size w h) = do
viewport $= (Position 0 0, size)
matrixMode $= Projection
loadIdentity
ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1
matrixMode $= Modelview 0
keyboard :: KeyboardMouseCallback
keyboard (Char ‘\27’) Down _ _ = exitWith ExitSuccess
keyboard _ _ _ _ = return ()
— Main Loop: Open window with initial window size, title bar, RGBA display
— mode, and handle input events.
main :: IO ()
main = do
(progName, args) <- getArgsAndInitialize
(size, pixels) <- readImage (if null args then “Data/leeds.bin” else head args)
initialDisplayMode $= [ SingleBuffered, RGBMode ]
initialWindowSize $= size
initialWindowPosition $= Position 100 100
_ <- createWindow progName
myInit
reshapeCallback $= Just reshape
keyboardMouseCallback $= Just keyboard
displayCallback $= display size pixels
mainLoop
colormatrix

Leave a comment