( Graphic Haiku, 28may11cht )
( Adapted from Brad Nelson's Haiku )


decimal

: break cr .s key 27 = abort" done" ;

\ 768 2 * constant width
\ 512 2 * constant height
200 constant width
200 constant height

variable 10K 10000 10K !
variable xx
variable yy
variable Temp 
variable Temp1
variable Temp2
variable Temp3

newcanvas

: 3DUP 2 PICK 2 PICK 2 PICK ;

: pix@ ( x y -- color )
  >R >R
  MEMDC R> R> GetPixel
;

: pix! ( x y color -- )
  >R height swap - 1- >R >R
  MEMDC R> R> R> SetPixel DROP
;

code init	finit ret end-code
code 1.0	fld1 ret end-code
code 0.0	fldz ret end-code
code pi	fldpi ret end-code
code log2e	fldl2e ret end-code
code 2**x	fld st
		frndint
		fsub st(1), st
		fxch
		f2xm1
		fld1
		fadd
		fscale
		fstp st(1)
		ret
		end-code
code ylog2x	fyl2x ret end-code
code dup	fld st ret end-code
code over	fld st(1) ret end-code
code swap	fxch ret end-code
code drop	fcomp ret end-code
code rot	fxch fxch st(2) ret end-code
code +		fadd ret end-code
code -		fsub ret end-code
code *		fmul ret end-code
code /		fdiv ret end-code
code mod	fxch fprem 
		fstp st(1) 
		ret end-code
code abs	fabs ret end-code
code sqrt	fsqrt ret end-code
code sin	fsin ret end-code
code cos	fcos ret end-code
code tan	fptan fcomp ret end-code
code atan2	fpatan ret end-code
code log	fldln2 fxch fyl2x ret end-code
code round	frndint ret end-code

code < ( f: f1 f2 -- 1/0 )
        fcompp
        fstsw   ax
        sahf
        jc @@1
	fld1
        ret
@@1:	fldz
        ret
        end-code

code >= ( f: f1 f2 -- 1/0 )
        fcompp
        fstsw   ax
        sahf
        jc @@1
	fldz
        ret
@@1:	fld1
        ret
        end-code

code > ( f: f1 f2 -- 1/0 )
	fxch
        fcompp
        fstsw   ax
        sahf
        jc @@1
	fld1
        ret
@@1:	fldz
        ret
        end-code

code <= ( f: f1 f2 -- 1/0 )
	fxch
        fcompp
        fstsw   ax
        sahf
        jc @@1      
	fldz
        ret
@@1:	fld1
        ret
        end-code

code = ( f: f1 f2 -- 1/0 )
        fcompp
        fstsw   ax
        sahf
	jz @@1
	fldz
        ret
@@1:    fld1
        ret
        end-code

code <> ( f: f1 f2 -- 1/0 )
        fcompp
        fstsw   ax
        sahf
        jz @@1
	fld1
        ret
@@1:	fldz
        ret
        end-code

: 0=	0.0 = ;

code (FLOAT) ( f: -- f )
        fild	Temp           \ FILD long-integer
        ret	end-code

: FLOAT ( n -- ; f: -- f )
        Temp ! (FLOAT)
        ;

code (FIX) ( f: f -- )
        fistp Temp 
        ret    end-code

: FIX ( -- n ; f: f -- )
        (FIX) Temp @
        ;
: e		271828 float 100000 float / ;
: pow		swap ylog2x 2**x ;
: exp		e swap pow ;


code 10K*
	fimul	10K
	ret
	end-code

: n.nnnn <# # # # # 46 hold #s #> type space ;

code (.s)
	fld	st(3)
	fimul	10K
	fistp	Temp3
	fld	st(2)
	fimul	10K
	fistp	Temp2
	fld	st(1)
	fimul	10K
	fistp	Temp1
	fld	st
	fimul	10K
	fistp	Temp
	ret
	end-code

: ?? 	@ n.nnnn ;
: f.s	(.s) Temp3 ?? Temp2 ?? Temp1 ?? Temp ?? ." > " ;

\ code @ ( f: -- f; a -- )       \ Intel temp-real 80 bits
\        pop 	bx
\        FILD 	0 [BX]
\        ret
\        end-code

\ code ! ( f: f -- ; a -- )      \ Intel temp-real 80 bits
\        pop 	bx
\        FISTP 	0 [BX]
\        ret
\        end-code

: to-color ( f: f -- ; -- color )
	255 float * fix 255 min
	;
: tenth ( f: -- f ; n -- , scale a fraction number )
	float 10 float / 
	;
: hundredth ( f: -- f ; n -- , scale a fraction number )
	float 100 float / 
	;
: thousandth ( f: -- f ; n -- , scale a fraction number )
	float 1000 float / 
	;

: x	( f: -- f , push x on floating point stack )
	xx @ float width float /
	;
: y	( f: -- f , push y on floating point stack )
	yy @ float height float /
	;
: red	( f: -- f )
	x  33 hundredth > ;
: green ( -- n , color shade 0-1 )
	x  50 hundredth - abs 17 hundredth < ;
: blue  ( -- n , color shade 0-1 )
	x  67 hundredth < ;
: france 	red green blue 
	;

variable 'draw
' france 'draw !
	
: haiku 0 yy !
	height for aft
		0 xx !
		width for aft
			xx @ yy @
			'draw @execute
			to-color 8 lshift
			to-color or 8 lshift
			to-color or pix!
			1 xx +!
		then next
		1 yy +!
	then next
	update
	;

haiku

: paint ' 'draw ! haiku ;
: and 	fix fix and if 1.0 else 0.0 then ;
: or	fix fix or  if 1.0 else 0.0 then ;
: xor	fix fix xor if 1.0 else 0.0 then ;

code max ( f: f1 f2 -- max )
        fcom
        fstsw   ax
        sahf
        jc @@1
	fstp st(1)
        ret
@@1:	fcomp
        ret
        end-code

code min ( f: f1 f2 -- min )
        fcom
        fstsw   ax
        sahf
        jc @@1
	fcomp
        ret
@@1:	fstp st(1)
        ret
        end-code

: rainbow
	x y x y * 10 float * 1 float mod
	;

: p1 x 15 float * sin y 10 float * cos / log cos ;
: p2 x 14 float * cos y 10 float * sin / log cos ;
: p3 x 10 float * cos y  9 float * cos / log cos ;
: p4 x 10 float * sin y 10 float * sin / log cos ;
\ over + push over + push +
\ pop pop

: fiberellum
	p1 p2 + p2 p3 + p3 p4 +
	;

: grid 7 float * sin swap 7 float * cos * dup * ;
: led	x 1.0 + y grid
	x y grid x + 
	x y grid ;

: air-force
	x 5 tenth - dup * y 5 tenth - dup * +
	dup 5 hundredth < swap
	dup 15 hundredth < swap
	3 tenth < ;

: difference
	x 30 float * sin y 
	min y 20 float * sin x <
	+ dup 7 tenth * 2 tenth 
	;

: fiberellum/bw
	x 33 float * sin y 7 float * cos / log cos
	x 3 float * sin y 25 float * sin / log cos
	+ dup dup ;

: 4spire
	x x 23 float * sin 2 float / y max / sin
	y x 23 float * sin 2 float / y max / sin
	over over / sin ;

: x' x 3 tenth - ;
: y' y 1 tenth + ;
: scales
	x' y' * 40 float * sin
	1.0 x' - y' * 30 float * sin *
	x' 1.0 y' - * 20 float * sin *
	dup x' / sin
	dup y' / cos 1.0 x - 1.0 y - + *
	;

: stripe
	y 4100 hundredth * sin 0.0 < ;
: star 
	x 71 float * sin  9 tenth > y 54 float * sin  9 tenth > and
	x 71 float * sin -9 tenth < y 54 float * sin -9 tenth < and
	or ;
: stripes 1.0 stripe stripe ;
: stars star star 1.0 ;
: usa
	x 5 tenth > 
	y 46 hundredth < or fix 
	if stripes else stars then
	;

: web ( n1 n2 -- ; f: -- fn )
	x 5 tenth + y 3 tenth + * float * sin 0.0 max
	x 3 tenth + y 5 tenth + * float * sin 0.0 max
	+ ;
: streak
	23 31 web 17 17 web * x +
	31 23 web 19 19 web * y x * +
	31 31 web 7 7 web * y +
	;

: orbit
	x y x 7 tenth * + * 4 tenth +
	dup 3 float pow
	dup 4 float pow
	x 2 tenth - dup * y 4 tenth - dup * + 1 tenth <
	x y * 5 float * * +
	;	

: red-mask
	x 6 tenth < x 4 tenth > and
	y 6 tenth < y 4 tenth > and or
	x y - abs 1 tenth < or
	1.0 x - y - abs 1 tenth < or
	;
: green-mask
	x 55 hundredth < x 45 hundredth > and
	y 55 hundredth < y 45 hundredth > and or
	x y - abs 5 hundredth < or
	1.0 x - y - abs 5 hundredth < or
	;
: england
	red-mask
	green-mask
	over over xor
	swap 1.0 xor
	;

: sine-spiral
	x 5 tenth - y 5 tenth - atan2
	x 5 tenth - dup * y 5 tenth - dup * +
	sqrt 20 float * + sin dup *
	dup dup
	;
: cosine-spiral
	x 48 hundredth - y 5 tenth - atan2
	x 48 hundredth - dup * y 5 tenth - dup * +
	sqrt 15 float * + cos 
	x 50 hundredth - y 5 tenth - atan2
	x 50 hundredth - dup * y 5 tenth - dup * +
	sqrt 20 float * + cos 
	x 52 hundredth - y 5 tenth - atan2
	x 52 hundredth - dup * y 5 tenth - dup * +
	sqrt 25 float * + cos 
	;

variable spikes 60 spikes !

: spike
	x 25 hundredth - y 75 hundredth - atan2
\	spikes @ tenth * sin dup * 8 hundredth * ( flower )
\	spikes @ tenth * 1.0 mod abs 8 hundredth * ( lotus )
	spikes @ tenth * pi / dup round - abs 16 hundredth * ( star )
	x 25 hundredth - dup * y 75 hundredth - dup * +
	sqrt + 20 hundredth 
	< ;

: taiwan 
	60 spikes !
	x 5 tenth < y 5 tenth > and 
	fix if spike dup 1.0 
	else 1.0 0.0 0.0 then 
	;

: 1arm
	5 tenth - abs 1 tenth <
	;
: 1mask
	dup 2 tenth > 
	swap 8 tenth <
	and 
	;

: switzerland
	1.0
	x 1arm y 1mask and 
        y 1arm x 1mask and or
	dup ;

: libya 0.0 1.0 0.0 ;
 
: red2	( f: -- f )
	x  20 hundredth > ;
: green2 ( -- n , color shade 0-1 )
	0.0 ;
: blue2  ( -- n , color shade 0-1 )
	x  20 hundredth < ;

: dagistan	red2 green2 blue2 
	;

: tataristan
	y  55 hundredth <
	y 45 hundredth >  
	over over and
	;

: japan 
	1.0	
	x 5 tenth - dup * y 5 tenth - dup * + 7 hundredth > 
	dup
	; 

: armenia
	y 33 hundredth < y 66 hundredth > or
	y 33 hundredth < 2 float /
	over 0=
	;

: austria
	1.0
	y 33 hundredth > y 66 hundredth < and
	dup
	;

: bahamas
	y x dup + < y 1.0 x dup + - > or fix
	if 	y 33 hundredth > y 66 hundredth < and
		dup dup 0= 
	else 0.0 0.0 0.0 then
	;

: bahram
	1.0
	y 75 tenth * dup round - abs 15 hundredth * 
	3 tenth + x > dup
	;

: bangladesh
	x 5 tenth - dup * y 5 tenth - dup * + 7 hundredth < 
	dup 0= 
	0.0
	; 

: belgium 
	x 33 hundredth >
	x 33 hundredth > x 66 hundredth < and
	0.0
	;

: benin
	x 33 hundredth >
	x 33 hundredth < y 5 tenth > or
	0.0	 
	;

: botswana
	y 5 tenth - abs dup 1 tenth > swap 2 tenth < and
	y 5 tenth - abs 1 tenth > 
	dup
	;

: bulgaria
	y 33 hundredth < y 66 hundredth > or
	y 33 hundredth >
	y 66 hundredth >
	;

: chad 
	x 33 hundredth >
	dup x 66 hundredth < and
	x 33 hundredth <
	;

: chile
	25 spikes !
	x 5 tenth < y 5 tenth > and 
	fix if spike dup 1.0 
	else 1.0 y 5 tenth > dup then 
	;

: estonia
	y 40 hundredth < dup dup
	y 60 hundredth > or
	;

: finland
	x 3 tenth - abs 1 tenth >
	y 5 tenth - abs 1 tenth > and dup
	1.0
	;

: gabon
	y 33 hundredth > y 66 hundredth < and
	y 33 hundredth >
	y 33 hundredth <
	;

: gambia
	y 65 hundredth > y 3 tenth > y 35 hundredth < and or
	y 35 hundredth < y 65 hundredth > y 7 tenth < and or
	y 7 tenth < y 3 tenth > and
	;  

: georgia
	y 75 hundredth < x 4 tenth > or
	y 75 hundredth < y 5 tenth > and x 4 tenth < and
	dup
	;

: germany
	y 66 hundredth <
	y 33 hundredth <
	0.0
	;

: stripe
	y 2838 hundredth * sin 0.0 < ;
: cross 
	x 15 hundredth > x 25 hundredth < and
	y 66 hundredth > y 77 hundredth < and
	or ;
: greece
	x 4 tenth > 
	y 44 hundredth < or fix 
	if stripe else cross then
	dup 1.0
	;

: guinea
	x 66 hundredth <
	x 33 hundredth >
	0.0
	;

: hungary
	y 33 hundredth >
	y 66 hundredth <
	over over and
	;


	paint fiberellum break
	paint led break
	paint air-force break
	paint difference break
	paint fiberellum/bw break
	paint 4spire break
	paint scales break
	paint streak break
	paint orbit break
	paint sine-spiral break
	paint cosine-spiral break
	paint libya break
	paint france break
	paint germany break
	paint england break
	paint usa break
	paint taiwan break
	paint armenia break
	paint austria break
	paint bahamas break
	paint bahram break
	paint bangladesh break
	paint belgium break
	paint benin break
	paint botswana break
	paint bulgaria break
	paint chad break
	paint chile break
	paint dagistan break
	paint estonia break
	paint finland break
	paint gabon break
	paint gambia break
	paint georgia break
	paint germany break
	paint greece break
	paint guinea break
	paint hungary break
	paint japan break
	paint switzerland break
	paint tataristan break