-
Notifications
You must be signed in to change notification settings - Fork 1
/
WINDOWS
1052 lines (846 loc) · 21.7 KB
/
WINDOWS
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
\ window classes
cr .( Loading generic wimp windows support...)
comment:
You will usually use WINDOWs by sending them a Start: message
passing the initial position. And you will close the window
by sending a Stop: message, what else.
GENERIC-WINDOWs are linked in a list so that the APPLICATION can
distribute the Wimp messages to the right GENERIC-WINDOW. (see pause')
WINDOWs are special GENERIC-WINDOWs which can respond to the
Wimp messages (On_*****: messages in WINDOW). You can do other
things with WINDOWs before opening them: SetTitleText: , Move: ,
GetSize: , Center: (get initial position so it will be centered
on the screen) and Print: .
Start: will Create: the WINDOW, then Open: it.
Create: sends a On_Init: message, then Move: and Build: itself.
Build: will create the memory structure for Wimp_CreateWindow.
When you say Stop: to a WINDOW, it Close: s and Delete: s itself.
The latter will invoke the newest On_Done: method.
So you may control the appearing and disappearing of WINDOWs in
several stages.
The basic work being done we can define a TEXT-WINDOW which
can display text. PutText: , PutCR: , BackSpace: , Cls: will
tell it what to display. You can control the cursor position.
The class EDIT-WINDOW can additionally gain the caret, although
I must admit that the handling is very incomplete.
CKey is a class to realise a circular key buffer. This could
be a place where keypresses to an application could be stored.
APPLICATIONs will distribute messages which arrive with them.
Keypresses to an object of CKey (PutKey:) , mouse clicks to the
appropriate WINDOW or ICONBAR-ICON (On_Click:)
In the end this file redefines the in/output deferred words
of the Forth system to work with windows.
comment;
\ part of fake caret
code drawcursor ( x y x1 y1 -- )
mov r3, tos
ldmfd sp !, { r4, r5, r6, tos }
mov r0, # 4
mov r1, r4
mov r2, r3
swi " OS_Plot"
mov r1, r6
mov r2, r5
mov r0, # 101
swi " OS_Plot"
next c;
code SetGraphicsColour
mov r1, tos
mov r0, # 0
swi " OS_SetColour"
ldmfd sp !, { tos }
next c;
code SetTextColour
mov r1, tos
mov r0, # %1000000
swi " OS_SetColour"
ldmfd sp !, { tos }
next c;
code SetGraphicsBgColour
mov r1, tos
mov r0, # %0010000
swi " OS_SetColour"
ldmfd sp !, { tos }
next c;
code SetTextBgColour
mov r1, tos
mov r0, # %1010000
swi " OS_SetColour"
ldmfd sp !, { tos }
next c;
: paper
SetGraphicsBgColour
16 OS_WriteC ;
\ mod to not draw background.
code Wimp_CreateTransWindow ( buf -- hndl )
mov r1, tos
add r8, r1, # 35 \ we draw background
mov r0, # &FF
strb r0, [ r8 ]
swi " Wimp_CreateWindow"
mov tos, r0
next c;
code Wimp_CreateWindow ( buf -- hndl )
mov r1, tos
swi " Wimp_CreateWindow"
mov tos, r0
next c;
code Wimp_DeleteWindow ( buf -- )
mov r1, tos
swi " Wimp_DeleteWindow"
ldmfd sp !, { tos }
next c;
code Wimp_OpenWindow ( buf -- )
mov r1, tos
swi " Wimp_OpenWindow"
ldmfd sp !, { tos }
next c;
code Wimp_CloseWindow ( buf -- )
mov r1, tos
swi " Wimp_CloseWindow"
ldmfd sp !, { tos }
next c;
code Wimp_RedrawWindow ( blk -- f )
mov r1, tos
swi " Wimp_RedrawWindow"
mov tos, r0
next c;
code Wimp_UpdateWindow ( blk -- f )
mov r1, tos
swi " Wimp_UpdateWindow"
mov tos, r0
next c;
code Wimp_GetRectangle ( buf -- f )
mov r1, tos
swi " Wimp_RedrawWindow"
mov tos, r0
next c;
code OS_Plot ( y x type -- )
mov r0, tos
ldmfd sp !, { r1, r2, tos }
swi " OS_Plot"
next c;
code Wimp_Initialise ( ^messages ^descr "TASK" osver -- thndl osver' )
mov r0, tos
ldmfd sp !, { r1, r2, r3 }
swi " Wimp_Initialise"
stmfd sp !, { r1 }
mov tos, r0
next c;
code Wimp_CloseDown ( "TASK" taskhndl -- )
mov r0, tos
ldmfd sp !, { r1, tos }
swi " Wimp_CloseDown"
next c;
code Wimp_Poll ( [^pollword] buf mask -- buf event )
mov r0, tos
tst r0, # &400000
ldmfd ne sp !, { r1, r3 }
ldmfd eq sp !, { r1 }
swi " Wimp_Poll"
mov tos, r0
stmfd sp !, { r1 }
next c;
code Wimp_SetCaretPosition ( index hght y x ihndl whndl -- )
mov r0, tos
ldmfd sp !, { r1, r2, r3, r4, r5, tos }
swi " Wimp_SetCaretPosition"
next c;
code Wimp_GetCaretPosition ( buf -- )
mov r1, tos
swi " Wimp_GetCaretPosition"
ldmfd sp !, { tos }
next c;
code Wimp_BlockCopy ( dymin dxmin symax sxmax symin sxmin whndl -- )
mov r0, tos
ldmfd sp !, { r1, r2, r3, r4, r5, r6, tos }
swi " Wimp_BlockCopy"
next c;
code Wimp_ReportError ( ^title flags ^errorblock -- res )
mov r0, tos
ldmfd sp !, { r1, r2 }
swi " Wimp_ReportError"
mov tos, r1
next c;
code Wimp_ForceRedraw ( ymax xmax ymin xmin whnd -- )
mov r0, tos
ldmfd sp !, { r1, r2, r3, r4, tos }
swi " Wimp_ForceRedraw"
next c;
code Wimp_GetWindowState ( block -- )
mov r1, tos
swi " Wimp_GetWindowState"
ldmfd sp !, { tos }
next c;
code Wimp_SendMessage ( Hicon Htask block eventcode -- )
mov r0, tos
ldmfd sp !, { r1, r2, r3, tos }
swi " Wimp_SendMessage"
next c;
\ &1 constant WF_TitleBar
&2 constant WF_Movable
\ &4 constant WF_VScrollBar
\ &8 constant WF_HScrollBar
&10 constant WF_WimpRedraws
&20 constant WF_Pane
&40 constant WF_Outside
\ &80 constant WF_NoBack/Close
&100 constant WF_ScrollReqAR
&200 constant WF_ScrollReq
&400 constant WF_GCOLours
&800 constant WF_NoBelow
&1000 constant WF_HotKeys
&2000 constant WF_StayOnScreen
&4000 constant WF_IgnoreR
&8000 constant WF_IgnoreL
&10000 constant WF_Open?
&20000 constant WF_OnTop?
&40000 constant WF_FullSize?
&80000 constant WF_ToggleSize?
&100000 constant WF_InputFocus?
&200000 constant WF_ForceOnScreen?
&81000000 constant WF_BackIcon
&82000000 constant WF_CloseIcon
&84000000 constant WF_TitleBar
&88000000 constant WF_ToggleSizeIcon
&90000000 constant WF_VScrollBar
&a0000000 constant WF_AdjSizeIcon
&c0000000 constant WF_HScrollBar
0 value windows-link
0 value applobj
0 value applwin
0 value barpopup
0 value lastpopup
0 value outwindow
create block 44 allot
:class generic-window <super object <classpointer
int hWnd
:m ClassInit: ( -- )
0 to hWnd
here windows-link , to windows-link
self , ;m
:m GetHandle: ( -- n )
hWnd ;m
:m ZeroWindow: ( -- )
0 to hwnd ;m
:m ~: ( -- )
windows-link cell+ @ self =
if windows-link @ to windows-link
else windows-link
begin dup @ ?dup
while dup cell+ @ self =
if @ swap ! exitm then
nip
repeat
then ;m
;class
:class window <super generic-window <classpointer
int xmin
int ymin
int xmax
int ymax
int xscroll
int yscroll
int behindhndl
int wflags
int ti/wacolour
int sb/ticolour
int waxmin
int waymin
int waxmax
int waymax
int TiIFlags
int WBType
int sprarea
int minsize
12 bytes title
int #icons
int mypopup
64 bytes title"
int ?open
int sbcol
int trans?
:m UpdateWindow:
^base Wimp_UpdateWindow ;m
: SetSize { dx dy -- }
screen-size
cells 44 - dy ymin + min to ymax
2* 22 - dx xmin + min to xmax ;
:m GetSize: ( -- x y )
xmax xmin - ymax ymin - ;m
: SetMinSize ( x y -- )
16 lshift swap &ffff and or to minsize ;
:m SetTitleText: ( ^str -- )
dup c@ 12 <
if count >r title r@ move 0 title r> + c!
TiIFlags [ IF_IndData invert ] literal and to TiIFlags
else count tuck title" place
title 8 + ! title" 1+ title ! title cell+ on
TiIFlags IF_IndData or to TiIFlags
then ;m
: SetTiColour ( fg bg sel -- )
&ff and 16 lshift sb/ticolour &ffff and or to sb/ticolour
&ff and 8 lshift swap &ff and or
ti/wacolour &ffff0000 and or to ti/wacolour
;
: SetWaColour ( fg bg -- )
&ff and 8 lshift swap &ff and or 16 lshift
ti/wacolour &ffff and or to ti/wacolour ;
: SetWaSize ( x y -- )
0 to waxmin 0 to waymax
negate to waymin to waxmax ;
: SetSBColour ( in out -- )
&ff and swap &ff and 8 lshift or
sb/ticolour &ff0000 and or to sb/ticolour
;
: SetScrollPos ( x y -- )
to yscroll to xscroll ;
: ChangeWFlags ( n mask -- )
wflags and or to wflags ;
:m ClassInit: ( -- )
ClassInit: super
640 320 SetSize
640 320 SetWaSize
0 0 SetMinSize
[ IF_Text nostack1
IF_Border or
IF_HCentered or
IF_VCentered or
IF_FilledBG or ] literal to TiIFlags
c" Window" SetTitleText: self
[ WF_Movable
WF_WimpRedraws or
WF_Outside or
WF_ScrollReqAR or
WF_IgnoreR or
WF_IgnoreL or
WF_BackIcon or
WF_CloseIcon or
WF_VScrollBar or
WF_AdjSizeIcon or
WF_HScrollBar or
WF_ToggleSizeIcon or
WF_TitleBar or ] literal 0 ChangeWFlags
1 to sprarea
Gray1 Gray3 SetSBColour
Black Gray2 Cream SetTiColour
Black White SetWaColour
BT_1/Drag/2 to WBType
-1 to behindhndl 0 to #icons
0 to mypopup ;m nostack1
:m Move: { px py -- }
screen-size
cells 44 - py ymax ymin - + min to ymax py to ymin
2* 22 - px xmax xmin - + min to xmax px to xmin ;m
:m Center: ( -- x y )
screen-size ymax ymin - - 2/
swap 2* xmax xmin - - 2/ swap 200 + ;m
:m Build: ( ad -- ad' )
^base cell+ ( hWnd ) over
88 move 88 + ;m
:m On_Init: ( -- )
;m
:m On_Done: ( -- )
;m
:m Delete: ( -- )
On_Done: [[ self ]]
hWnd block !
block Wimp_DeleteWindow
0 to hWnd ;m
:m Create: ( x y -- )
hWnd if Delete: self then
On_Init: [[ self ]]
Move: self
here 512 + aligned dup Build: [[ self ]] drop
trans? if
Wimp_CreateTransWindow to hWnd
else
Wimp_CreateWindow to hWnd
then
initSprites? 1 = if
toSprite
&AAAAAA paper
then
;m
:m Open: ( -- )
hWnd 0= if xmin ymin Create: self then
^base Wimp_OpenWindow
true to ?open
;m
:m Close: ( -- )
hWnd block !
block Wimp_CloseWindow
false to ?open ;m
:m Start: ( x y -- )
hwnd 0= if Create: self else Move: self then
Open: self
;m
:m Stop:
Close: self
Delete: self ;m
:m On_Open: ( block -- )
cell+
lcount to xmin lcount to ymin
lcount to xmax lcount to ymax
lcount to xscroll lcount to yscroll
@ to behindhndl
Open: self
;m
:m On_Close: ( block -- )
drop Close: self ;m
:m On_Menu: ( block -- )
mypopup
if dup @ 64 - swap 4+ @ start: mypopup
mypopup to lastpopup
else drop then ;m
:m On_Select: ( block -- )
drop ;m
:m On_Adjust: ( block -- )
drop ;m
:m On_Click: ( block -- )
dup 8+ c@
case 4 of On_Select: [[ self ]] endof
2 of On_Menu: [[ self ]] endof
1 of On_Adjust: [[ self ]] endof
nip
endcase
;m
:m &popup: ( -- ^obj )
&> mypopup ;m
:m Print:
." Window@" ^base . ." Title: "
TiIFlags IF_IndData and
if title" count type
else title zcount type
then ;m
;class
: ErrorBox ( z"ErrorText -- res )
z" Message from WimpForth"
%10010011
rot Wimp_ReportError ;
align
variable caretpos 64 allot
\ no need to malloc this
create screenmem 20 1024 * allot
0 value spron
&AA0000 value fcolr
77 value bcolr
:class text-window <super window
int cols
int rows
int &thescreen
int &endscreen
int &title
int xcur
int ycur
int curon
\ sprite or rectangle.
: redraw
toScreen
spron if
xmin ymin plotSprite
else
bcolr gcol
12 OS_WriteC
then ;
: Update+Clear ( x1 y1 x2 y2 -- )
-32* 32+ swap 16* 32+ 2swap 1+ -32* swap 16*
Hwnd Wimp_ForceRedraw
;
: hascaret?
caretpos Wimp_GetCaretPosition
caretpos @ hWnd =
;
:m HideCaret:
-1 0
-10 -10
-1 Hwnd
Wimp_SetCaretPosition
0 to curon
;m
:m On_LoseCaret: ( block )
0 to curon
xcur ycur xcur 1+ over Update+Clear
drop
;m
:m On_GainCaret: ( block )
-1 to curon
xcur ycur xcur 1+ over Update+Clear
drop
;m
:m ShowCaret:
0 0
ycur 1+ -32* xcur 16*
-1 Hwnd
Wimp_SetCaretPosition
-1 to curon
;m
:m GainCaret:
HideCaret: self
;m
:m On_Click: ( block -- )
GainCaret: self
xcur ycur xcur 1+ over Update+Clear
On_Click: super
;m
:m ClassInit: ( ^title cols rows -- )
ClassInit: super
0 WF_WimpRedraws invert ChangeWFlags
to rows to cols
cols 16* rows 5 lshift 2dup
SetSize SetWaSize
-1 to trans?
SetTitleText: self ;m
:m On_Init: ( -- )
screenmem to &thescreen
screenmem cols rows * + to &endscreen ;m
:m On_Done: ( -- )
0 to &thescreen 0 to &endscreen
;m
2variable plotpos
code rectcalc ( cols block -- ad len #lines y x )
ldr r2, [ tos, # 16 ]
ldr r0, [ tos, # 24 ]
sub r2, r2, r0 \ r2=work_y0
ldr r0, [ tos, # 40 ]
sub r2, r2, r0
mov r3, r2, lsr # 5
ldmfd sp !, { r1 }
mul r3, r1, r3
and r2, r2, # &1f
add r0, r0, r2
sub r0, r0, # 2
ldr r1, [ tos, # 32 ]
sub r1, r0, r1
add r1, r1, # &1f
mov r1, r1, lsr # 5
ldr r2, [ tos, # 4 ]
ldr r4, [ tos, # 20 ]
sub r2, r2, r4 \ r2=work_x0
ldr r4, [ tos, # 28 ]
sub r5, r4, r2
ldr r2, [ tos, # 36 ]
add r3, r3, r5, lsr # 4
and r5, r5, # &f
sub tos, r4, r5
sub r2, r2, tos
add r2, r2, # &f
mov r2, r2, lsr # 4
stmfd sp !, { r0, r1, r2, r3 }
next c;
\ fake a cursor
: draw_block
toScreen
hascaret?
xmin 0 >
ymin 0 >
curon
state @ 0 =
and and and and if
7 gcol
xmin xcur 16* + 2+
ymax ycur 1+ -32* + 4+
xmin xcur 16* + 20 +
ymax ycur 1+ -32* + 12 -
drawcursor
0 gcol
then ;
: DoRectangle
redraw
cols 2r@ drop
rectcalc ( ad len #lines y x )
plotpos 2! 0
?do plotpos 2@ 188 OS_Plot \ position on the screen
over &thescreen + dup &endscreen >= if drop leave then
over \ determine string to print
fcolr SetGraphicsColour
-trailing OS_WriteN \ print it
-32 plotpos cell+ +! \ bump screen pos
swap cols + swap \ bump source
loop 2drop
draw_block
;
:m On_Redraw: ( block -- )
ToScreen
dup>r Wimp_RedrawWindow
begin while
DoRectangle
r@ Wimp_GetRectangle
repeat r>drop
;m
: Update ( x1 y1 x2 y2 -- ) \ 1=bottom left
-32* block dup>r 16+ ! \ 2=top right
16* r@ 12 + ! 1+ -32* r@ 8+ ! 16* r@ 4+ !
hWnd r@ !
ToScreen
r@ Wimp_UpdateWindow
begin while
DoRectangle
r@ Wimp_GetRectangle
repeat r>drop
;
:m Redraw:
0 0 cols rows Update 0 rows 1- cols 0
toScreen
Update
toSprite
;m
: PutText ( ad len -- x y )
dup xcur + cols - dup 0>=
if - else drop then tuck
&thescreen ycur cols * + xcur + swap cmove
xcur ycur rot +to xcur
curon if
xcur 1- ycur xcur 1+ ycur Update+Clear
then ;
: UpdateText ( x y -- )
xcur ycur Update
;
:m PutText: ( ad len -- )
PutText UpdateText
;m
: Scroll ( -- )
ToScreen
&thescreen cols + &thescreen rows 1- cols * dup>r cmove
&thescreen r> + cols blank
rows 1- -32* 0 -32 cols 16* rows -32* 0 hWnd
spron if
vsync
Wimp_BlockCopy
Redraw: self
else
Wimp_BlockCopy
then
;
:m PutCR: ( -- )
0 to xcur
ycur 1+ rows =
if Scroll
0 rows 1- cols over Update+Clear
else 1 +to ycur then
0 to curon
;m
:m BackSpace: ( -- )
xcur if -1 +to xcur
xcur ycur xcur 1+ over Update+Clear
else 7 OS_WriteC then
;m
:m Cls: ( -- )
toScreen
&thescreen cols rows * blank
0 rows 1- cols 0 Update+Clear
0 to xcur 0 to ycur
;m
:m GetXY: ( -- x y )
xcur ycur ;m
:m GotoXY: ( x y -- )
to ycur to xcur
;m
:m GetColRow: ( -- col row )
cols rows ;m
;class
variable cblock
:class CKey <super object
132 bytes &keybuf
:m ClassInit:
0 &keybuf w! ;m
:m IsKey?: ( -- f )
&keybuf count swap c@ <> ;m
: bump &keybuf + dup c@ 2+ &7f and swap c! ;
:m PutKey: ( c -- )
&keybuf count swap c@ 2 - &7f and <>
if &keybuf count + 1+ w! 0 bump
else drop beep then ;m
:m GetKey: ( -- c )
&keybuf count over c@ <>
if count + w@ 1 bump
else drop -1 then ;m
:m On_Key: ( block -- )
24 + w@ PutKey: self
;m
;class
:class edit-window <super text-window <classpointer
:m ClassInit: ( cols rows -- )
ClassInit: super
BT_Click to WBType ;m
:m On_Select: ( block -- )
drop ;m
:m PutText: ( ad len -- )
PutText UpdateText
;m
:m PutCR: ( -- )
0 to xcur
ycur 1+ rows =
if Scroll else 1 +to ycur then
0 ycur cols over Update+Clear
;m
;class
also classes
: getwin ( block -- block obj )
dup @ windows-link
begin ?dup
while 2dup cell+ @ GetHandle: [[ ]] =
if nip cell+ @ exit then
@
repeat abort" Window not found!" ;
: zero-windows ( -- )
windows-link
begin ?dup
while dup cell+ @ ZeroWindow: [[ ]] @
repeat ;
previous
0 value OSVer
0 value TaskHndl
variable pausecfa
: .platform
." RISC OS " base @ >r decimal
OSVer 0 <# # # ascii . hold # #> type space r> base !
kbuild . ." Bit kernel" ;
s" WimpForth Window" drop 1- 96 32 edit-window mainwindow
mainwindow dup to outwindow to applwin
:class iconbar-icon <super icon <classpointer
:m ClassInit: ( ^str -- )
[ IF_Sprite IF_IndData or BT_Click or ] literal 0
ChangeIFlags: iconblock
SetText: iconblock
WH_IconBarR to hWnd
0 0 Move: iconblock
68 68 SetSize: iconblock
0 to hIcon ;m
:m On_Click: ( blk -- )
dup 8+ c@
case 2 of @ 64 - -96 start: barpopup
barpopup to lastpopup endof
4 of drop open: mainwindow endof
endcase
;m
;class
" !wimpforth" drop 1- iconbar-icon ibicon
defer On_DataLoad ( ad len -- )
also classes
align
:class application <super object <classpointer
CKey keybuf
create PollBuf 256 allot
: pause'
toScreen
PollBuf 0 Wimp_Poll
case
1 of On_Redraw: [[ getwin ]] endof
2 of On_Open: [[ getwin ]] endof
8 of On_Key: applobj endof
12 of On_GainCaret: [[ getwin ]] endof
11 of On_LoseCaret: [[ getwin ]] endof
9 of On_MenuSelection: applobj endof
6 of On_Click: applobj endof
3 of On_Close: [[ getwin ]] endof
17 of On_UMessage: applobj endof
18 of On_UMessageRec: applobj endof
\ 19 of On_UMessageAck: [[ getwin ]] endof
\ 7 of On_DragBox: [[ getwin ]] endof
\ 4 of On_PointerLeaving: [[ getwin ]] endof
\ 5 of On_PointerEntering: [[ getwin ]] endof
\ 10 of On_ScrolReq: [[ getwin ]] endof
\ 13 of On_NonZeroPollWord: [[ getwin ]] endof
( otherwise ) nip ( the pointer to block )
endcase toSprite ;
:m ClassInit:
applobj abort" Only one Application!"
self to applobj ;m
create d&dbuf 64 allot
: message ( block -- )
case dup 16+ @
0 of drop bye endof
3 of dup 44 + zcount d&dbuf place
dup 8+ @ over 12 + !
4 over 16+ !
0 swap dup 4+ @ swap 17 Wimp_SendMessage pause
d&dbuf count On_DataLoad endof
nip
endcase ;
:m On_UMessageRec: ( block -- ) message ;m
:m On_UMessage: ( block -- ) message ;m
:m Start: ( -- )
block off
block z" WimpForth" &4b534154 310 Wimp_Initialise
to OSVer to TaskHndl
['] pause' ['] pause dup @ pausecfa ! call!
['] pause' is outpause
zero-windows
Create: ibicon ;m
:m On_Click: ( block -- )
dup 12 + @ -2 =
if ibicon
else dup 12 + getwin nip then
On_Click: [[ ]] ;m
:m On_MenuSelection: ( block -- )
Execute: lastpopup ;m
:m On_Key: On_Key: keybuf ;m
:m IsKey?: ( -- f ) IsKey?: keybuf ;m
:m PutKey: ( c -- ) PutKey: keybuf ;m
:m GetKey: ( -- c ) GetKey: keybuf ;m
;class previous
: wpushkey ( c -- )
PutKey: applobj ;
: w"pushkeys ( a1 n1 -- ) \ push the characters of string a1,n1
0max 127 min bounds
?do i c@ pushkey
loop ;
: loadit s" fload " "pushkeys "to-pathend" "pushkeys 13 pushkey ;
' loadit is On_DataLoad
' wpushkey is pushkey
' w"pushkeys is "pushkeys
: wtype ( ad len -- )
PutText: outwindow outpause ;
: wemit ( c -- )
dup bl <
if
case
7 of 7 OS_WriteC endof
8 of BackSpace: outwindow endof
10 of PutCR: outwindow endof
endcase
else sp@ 1 wtype drop then
;
: wcr PutCR: outwindow
HideCaret: outwindow ;
: wcrtab
PutCR: outwindow
tabing? 0= ?exit
first-line?