kolibrios/programs/develop/SPForth/meforth_samples/picture.f
Kirill Lipatov (Leency) 09488af869 KolSPForth12 uploaded to SVN
git-svn-id: svn://kolibrios.org@4867 a494cfbc-eb01-0410-851d-a64ba20cac60
2014-04-21 19:22:58 +00:00

110 lines
2.4 KiB
Forth
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

DECIMAL
S" /rd/1/menuet.f" INCLUDED
: not_emit
emit_proc DUP @ NOT SWAP ! ;
new_reg wnd_size
CREATE Music $3090 , \ $90 C, $30 C, 0 C,
73 CONSTANT img.width
22 CONSTANT img.height
CREATE raw img.width img.height * 3 * 16 + ALLOT
: my_wnd
12 ax 1 bx sysv DROP $805080D0 DUP $02AABBCC 200 150 << 200 DUP << 0
sys6 2 bx sysv 2DROP
$10DDEEFF $" <EFBFBD><EFBFBD>ˆŒ…<EFBFBD> <EFBFBD><EFBFBD>Žƒ<EFBFBD>€ŒŒ" COUNT 8 DUP sys_print
0 $" <EFBFBD> ¦¬¨â¥ «î¡ãî ª« ¢¨èã" COUNT 8 30 sys_print
$6688DD 1 5 12 << 200 19 - 12 << 8 sys5 DROP
30 DUP << img.width img.height << raw 12 + 7 sys4 ;
: my_wnd_resize
200 dx 50 si 67 ax -1 DUP bx cx sysv DROP ;
: my_key
2 sys1 8 RSHIFT DUP 96 = IF not_emit DROP ELSE Music DUP si 1+ C!
55 DUP ax bx sysv DROP THEN ;
: my_btn
17 sys1 8 RSHIFT ." Pressed button #" DUP . CR 1 = IF BYE THEN ;
CREATE handlers ' my_wnd , ' my_key , ' my_btn ,
VARIABLE hnd
: msg_loop_console ( subs -- )
CR DUP hnd ! @EXECUTE my_wnd_resize
0 emit_proc !
BEGIN
10 sys1 ?DUP
IF
1-
CELLS hnd @ + @EXECUTE
emit_proc @
IF
WINDOW KEY 96 =
IF
not_emit hnd @ @EXECUTE my_wnd_resize
ELSE
EXIT
THEN
THEN
THEN
AGAIN ;
CREATE gif 600 ALLOT
: new_me ( new main loop)
gif DUP $" /rd/1/Menu.gif" COUNT READ 2DROP
gif raw READ_GIF .
;
new_me handlers msg_loop_console WORDS
ABORT
: ENDOF ( orig1 #of -- orig2 #of )
>R ( ïåðåìåñòèòü ñî ñòåêà â ñëó÷àå, åñëè )
( ñòåê ïîòîêà óïðàâëåíèÿ ýòî ñòåê äàííûõ. )
POSTPONE ELSE
R> ( ìû äîëæíû òåïåðü âåðíóòü ñ÷åò÷èê íàçàä )
; IMMEDIATE
: ENDCASE ( orig1..orign #of -- )
POSTPONE DROP ( óäàëèòü case ïàðàìåòð )
0 ?DO
POSTPONE THEN
LOOP
; IMMEDIATE
[THEN]
: SS2 ( N ---> S:ÑÓÌÌÀ ÊÂÀÄÐÀÒÎÂ ÎÒ 1 ÄÎ N)
0 SWAP ( 0,N S[0]=0 )
1+ 1 ( S[0],N+1,1 )
DO I ( S[I-1],I )
DUP * + ( S[I] S[I]=S[I-1]+I*I)
LOOP ; ( S[N] )
5 SS2 . CR
: test 10 0 ?DO I . LEAVE LOOP 4 ;
test
: priem ( N:ÍÎÌÅÐ ÄÍß->) CASE
3 OF ." nepriemn" ENDOF
1 OF ." priemn" ENDOF
6 OF ." holiday" ENDOF
CR . ." - day #?" ABORT
( ENDCASE ) ." day" ;