plasma.4k

| FourK - Concatenative, stack based, Forth like language optimised for 
|        non-interactive 4KB size demoscene presentations.
|
| Copyright (C) 2009, 2010 Wojciech Meyer, Josef P. Bernhart
|
| This program is free software: you can redistribute it and/or modify
| it under the terms of the GNU General Public License as published by
| the Free Software Foundation, either version 3 of the License, or
| (at your option) any later version.
|
| This program is distributed in the hope that it will be useful,
| but WITHOUT ANY WARRANTY; without even the implied warranty of
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
| GNU General Public License for more details.
|
| You should have received a copy of the GNU General Public License
| along with this program.  If not, see <http://www.gnu.org/licenses/>.
| ______________________________________________________________________


| This is only for interactive sessions, forget all the defined words
| so far marked
forget
| Mark that from this point to forget words
mark
| Define floating point constant
| leaves the constant on the floating point stack
: fconst : rliteral postpone >f postpone ; ;
| Put integer value on floating point stack
: i>>f i>f >f ;
| The following is very clumsy, will be changed in future
2 ccall: exit
3 ccall: SDL_SetVideoMode
4 ccall: SDL_PollEvent
5 ccall: SDL_Flip
6 ccall: SDL_LockSurface
7 ccall: SDL_UnlockSurface
| load our symbols from dll
| Must be in the same order as above
: libSDL " /usr/lib/libSDL.so" lib ;
: function >r sym r> cells add-handle ;
: load-symbols ( -- )
    " libc.so" lib " _exit" 1 function
    libSDL " SDL_SetVideoMode" 4 function
    libSDL " SDL_PollEvent" 1 function
    libSDL " SDL_Flip" 1 function
    libSDL " SDL_LockSurface" 1 function
    libSDL " SDL_UnlockSurface" 1 function
;
| some constants
800 const width
600 const height
32  const bpp
bpp 8 / const point
| SDL constants
27  const Esc
2   const Keydown
| SDL structure dispatch
: e>type c@ ;
: e>key 8 + c@ ;
: s>pixels 20 + @ ;
| out screen surface
variable screen
| allot needed stuff for SDL
create event 20 bytes allot
| and for pallete
create pallete 256 cells allot
| get the linear offset
: points point * ;
| put the pixel in right place with pallete colour
: pixel ( col x y -- ) width * + points screen @ s>pixels + swap cells pallete + @ swap ! ;
| set the video mode
: video 0 bpp height width SDL_SetVideoMode ;
| alias for convenience
: y postpone j ; immediate
: x postpone i ; immediate
| sqr function
: sqr dup * ;
| some more constants
width  2 / i>f fconst w/2
height 2 / i>f fconst h/2
| our sin (or cos I dunno) function
: fsin fsincos f> drop ;
| some pimped sin function which keeps value 0. - 255.
: sin fsin 127.0 >f f* 128.0 >f f+ ;
: dupf f> dup >f >f ;
| factoring could be done here
: nx i>f >f w/2 f- ;
: ny i>f >f h/2 f- ;
| some float constants
: swapf f> f> swap >f >f ;
1.0 >f 8.0 >f swapf f/ f> fconst c1/8
1.0 >f 16.0 >f swapf f/ f> fconst c1/16
1.0 >f 32.0 >f swapf f/ f> fconst c1/32
: isqrf i>>f dupf f* ;
| we needed to split the word into second one because of -127 limit for a loop
: draw2
    x isqrf 
    y isqrf 
    f+ fsqrt
    c1/8 f* sin
;
| draw it!
: draw
    height 1- 0 do
	width 1- 0 do
	    finit
	    x i>>f c1/16 f* sin 
	    y i>>f c1/32 f* sin f+

	    x nx dupf f* 
	    y ny dupf f* 
	    f+ fsqrt
	    
	    c1/8 f* sin
	    f+
	    draw2 f+
	    
	    f> f>i 4 / x y pixel
	loop
    loop
;
3.1415 fconst pi
: col> ( i f:fac -- f:c ) i>>f pi f* f* sin ;
: col! ( c i -- ) cells pallete + + f> f>i swap c! ;
: color ( i f ) dup >r col> r> col! ;
| init our pallete
: init-pallete
    256 0
    do
	finit
	0 i c1/8 color
	1 i c1/16 color
	2 i c1/32 color 
    loop
;
: draw
    screen @ SDL_LockSurface drop
    draw
    screen @ SDL_UnlockSurface  drop
    screen @ SDL_Flip drop
;
: render-loop
    begin
        draw
        event SDL_PollEvent drop
        event e>type Keydown = if event e>key Esc = if ;; then then
    again
;
: main
    load-symbols
    init-pallete
|    video screen !
|    render-loop
    0 exit
;

| save-image im.4ki
main