1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
module Main(main) where
import Graphics.UI.Japi.Binding
import Graphics.UI.Japi.Types
import Graphics.UI.Japi.Constants
import Control.Monad
data CalcState = CalcState { x, y, width, height :: Int,
lxs, xstart, lys, ystart, lxe, xend, lye, yend :: Double,
dowork :: Bool,
print, quit, start, stop, reset :: MenuItem }
main = do -- j_setdebug 4
rv <- j_start
when (j_FALSE == rv) (error "Could not start the JAPI server (jre or java)")
frame <- j_frame ""
j_setborderlayout frame
menubar <- j_menubar frame
file <- j_menu menubar "File"
calc <- j_menu menubar "Calc"
prin <- j_menuitem file "Print"
qui <- j_menuitem file "Quit"
star <- j_menuitem calc "Start"
sto <- j_menuitem calc "Stop"
rese <- j_menuitem calc "Reset"
ics <- ( return (CalcState { width = 640,
height = 480,
lxs = -1.8,
xstart = -1.8,
lxe = 0.8,
xend = 0.8,
lys = -1.0,
ystart = -1.0,
lye = 1.0,
yend = 1.0,
x = -1,
y = -1,
dowork = False,
Main.print = prin ,
quit = qui ,
start = star ,
stop = sto ,
reset = rese }) )
canvas <- j_canvas frame (width ics) (height ics)
pressed <- j_mouselistener canvas j_PRESSED
dragged <- j_mouselistener canvas j_DRAGGED
j_setpos canvas 10 60
j_setnamedcolorbg (Object (unCanvas canvas)) j_YELLOW
j_pack frame
j_show (Object (unFrame frame))
waitForFrameAction frame canvas ics
return j_quit
elToMenuItem :: EventListener -> MenuItem
elToMenuItem obj = MenuItem (unEventListener obj)
elToCanvas :: EventListener -> Canvas
elToCanvas obj = Canvas (unEventListener obj)
startCalcState :: CalcState -> CalcState
startCalcState cs = cs { xstart = lxs cs,
xend = lxe cs,
ystart = lys cs,
yend = lye cs,
x = -1,
y = -1,
dowork = True }
resetCalcState :: CalcState -> CalcState
resetCalcState cs = cs { lxs = -1.8,
xstart = -1.8,
lxe = 0.8,
xend = 0.8,
lys = -1.0,
ystart = -1.0,
lye = 1.0,
yend = 1.0,
x = -1,
y = -1 }
stopCalcState :: CalcState -> CalcState
stopCalcState cs = cs { dowork = False }
waitForFrameAction :: Frame -> Canvas -> CalcState -> IO CalcState
waitForFrameAction frame canvas calcState =
do obj <- if dowork calcState
then j_getaction
else j_nextaction
objMI <- return $ elToMenuItem $ obj
objCan <- return $ elToCanvas $ obj
(again, state) <- if objMI == quit calcState then return (False, calcState) else
if objMI == start calcState then do j_setnamedcolorbg canvasobj j_WHITE
return (True, startCalcState calcState)
else
if objMI == reset calcState then do j_setnamedcolorbg canvasobj j_WHITE
return (True, resetCalcState calcState)
else
if objMI == stop calcState then return (True, stopCalcState calcState) else
if objMI == Main.print calcState then do j_print canvasobj
return (True, calcState)
else
if objCan == canvas
then do j_setnamedcolorbg canvasobj j_WHITE
return (True, calcState { x = -1,
y = -1 })
else return (True, calcState)
state <- if dowork state
then do newstate <- return state { y = y state + 1 }
if y newstate >= width newstate
then return newstate { y = 0, dowork = False }
else let (rs, gs, bs) = makergbs newstate canvas [] [] []
in do
j_drawimagesource canvas 0 (y newstate) (width newstate) 1 rs gs bs
j_sync
return newstate
else return state
if not again
then return state
else waitForFrameAction frame canvas state
where canvasobj = (Object (unCanvas canvas))
mandel :: Double -> Double -> Double -> Double -> Int -> Int -> Int
mandel x y zre zim maxiter iter =
if iter1 >= maxiter
then maxiter
else let x1 = x * x - y * y + zre
y1 = 2 * x * y + zim
in if x1*x1 + y1*y1 > 4.0
then iter1
else mandel x1 y1 zre zim maxiter iter1
where iter1 = iter+1
makergb :: CalcState -> (Int, Int, Int)
makergb cs = let zre = xstart cs + (fromIntegral (x cs)) * ( xend cs - xstart cs ) / (fromIntegral (width cs))
zim = ystart cs + (fromIntegral (y cs)) * ( yend cs - ystart cs ) / (fromIntegral (height cs))
it = mandel 0.0 0.0 zre zim 512 0
in (it * 11, it * 13, it * 17)
makergbs :: CalcState -> Canvas -> [Int] -> [Int] -> [Int] -> ([Int], [Int], [Int])
makergbs cs canvas rs gs bs = let ncs = cs { x = x cs + 1 }
in if x ncs >= width ncs
then (rs, gs, bs)
else let (r,g,b) = makergb ncs
in makergbs ncs canvas (rs ++ [r]) (gs ++ [g]) (bs ++ [b])
|
