kolibrios/programs/develop/SPForth/meforth_samples/picture.f

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 $" <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>" COUNT 8 DUP sys_print
  0 $" <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><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    ( <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>, <EFBFBD><EFBFBD><EFBFBD><EFBFBD> )
                ( <EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>. )
          POSTPONE ELSE
          R>    ( <EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> )
        ; IMMEDIATE

        : ENDCASE  ( orig1..orign #of -- )
        	
          POSTPONE DROP  ( <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> case <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> )
          0 ?DO
            POSTPONE THEN
          LOOP
        ; IMMEDIATE

[THEN]

          : SS2   ( N ---> S:<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD> 1 <EFBFBD><EFBFBD> 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:<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD>->)   CASE
        3 OF ." nepriemn"  ENDOF

        1 OF ." priemn" ENDOF

        6 OF ." holiday" ENDOF

        CR . ." - day #?" ABORT 
        ( ENDCASE ) ." day" ;