requires clink.f
requires mapin.f
requires random.f
\ requires dbuf.f

"" my_pid.o clink

decimal

640 constant fb_width
480 constant fb_height

hex
4000 constant fb_size

variable >fb

: fb >fb @ ;

: rnd ( n --- 0..n-1 )
  random 2/ 2/ 2/ swap mod ;

hex

0800 constant gr_x_select 
\ Access a column in the frame buffer 

0000 constant gr_y_select 
\ Access a row in the frame buffer 

0200 constant gr_y_fudge 
\ Bit 9 not used at all  

2000 constant gr_update 
\ Update frame buffer if this bit set 

1b80 constant gr_x_rhaddr 
\ Location to read X address bits A9-A8. 
\ Data put into D1-D0. 

1b00 constant gr_x_rladdr 
\ Location to read X address bits A7-A0.
\ Data put into D7-D0. 

1bc0 constant gr_y_rhaddr 
\ Location to read Y address bits A9-A8. 

1b40 constant gr_y_rladdr 
\ Location to read Y address bits A7-A0. 


0000 constant gr_set0 
\ Address Register pair 0. 

0400 constant gr_set1 
\ Address Register pair 1. 


1000 constant gr_red_cmap 
\ Address to select Red Color Map 

1100 constant gr_grn_cmap 
\ Addr for green Color Map 

1200 constant gr_blu_cmap 
\ Addr for Blue Color Map 


1800 constant gr_sr_select 
\ Addr to select status register 

1900 constant gr_cr_select 
\ Addr to select mask (color) register 

1a00 constant gr_fr_select 
\ Addr to select function register 


\ The following are pointers to the mask(color), status, and function regs. 

: gr_creg  fb gr_cr_select + ;
: gr_mask  fb gr_cr_select + ;
: gr_sreg  fb gr_sr_select + ;
: gr_freg  fb gr_fr_select + ;

\ These assignments are for bits in the Status Register 

00 constant grw0_cplane 
\ Select CMap Plane number zero for R/W 

01 constant grw1_cplane 
\ Select CMap Plane number one for R/W 

02 constant grw2_cplane 
\ Select CMap Plane number two for R/W 

03 constant grw3_cplane 
\ Select CMap Plane number three for R/W 

04 constant grv0_cplane 
\ Select CMap Plane number zero for video 

05 constant grv1_cplane 
\ Select CMap Plane number one for video 

06 constant grv2_cplane 
\ Select CMap Plane number two for video 

07 constant grv3_cplane 
\ Select CMap Plane number three for video 

10 constant gr_inten
\ Enable Interrupt to start at start
\ of next vertical retrace. Must clear bit to
\ clear interrupts. 

20 constant gr_paint 
\ Enable Writing five pixels in parallel 

40 constant gr_disp_on 
\ Enable Video Display 

80 constant gr_vretrace 
\ Unused on write. On read, true if monitor in
\ vertical retrace. 


\ The following are function register encodings 

cc constant gr_copy 
\ Copy data reg to Frame buffer 

33 constant gr_copy_invert 
\ Copy inverted data reg to FB  

f0 constant gr_wr_creg 
\ Copy color reg to Frame buffer 

f0 constant gr_wr_mask 
\ Copy mask to Frame buffer 

0f constant grinv_wr_creg 
\ Copy inverted Creg to FB 

0f constant grinv_wr_mask 
\ Copy inverted Mask to FB 

55 constant gr_ram_invert 
\ 'Invert' color in Frame buffer 

c0 constant gr_cr_and_dr 
\ Bitwise and of color and data regs 

00 constant gr_clear 
\ Clear frame buffer 

5a constant gr_cr_xor_fb 
\ Xor frame buffer data and Creg 


: get_fb
  0 fb_size [""] /dev/cgone0 mapin  >fb !
  gr_copy gr_freg c!
  gr_disp_on gr_sreg c!
  0ff gr_mask c!
  _my_pid ret seed +!
;


\ : xsel ( x --- addr )
\   fb gr_x_select + gr_update + + ;

code xsel ( x --- addr )
  >fb l#) d0 long move
  gr_x_select gr_update + l# d0 long add
  d0 sp ) add
  next
c;

\ : ysel ( y --- addr )
\   fb gr_y_select + gr_update + + ;

code ysel ( y --- addr )
  >fb l#) d0 long move
  gr_y_select gr_update + l# d0 long add
  d0 sp ) add
  next
c;

: lineaddr ( y --- addr )
  ysel c@ drop
  0 xsel
;

: coladdr ( x --- addr )
  xsel c@ drop
  0 ysel
;

code xyaddr ( x y --- addr )
  sp )+  d1  long move
\  gr_y_select #  d1  word add
  >fb l#)  a0  long move
  d2  0 d1 a0 di)  byte move		\ select y
  a0 d0 long move
  gr_x_select gr_update + l#  d0  long add
  d0  sp )  long add
  next
c;

code plot ( x y c --- )
  sp )+  d2  long move
  sp )+  d1  long move
\  gr_y_select #  d1  word add
  sp )+  d0  long move
  gr_x_select gr_update + #  d0  word add
  >fb l#)  a0  long move
  d2  0 d1 a0 di)  byte move		\ select y
  d2  0 d0 a0 di)  byte move		\ update x
  next
c;

create (retrace assembler
  begin
    gr_sr_select a0 d)  d0  byte move
    80 #  d0 byte and 
  0= until
  begin
    gr_sr_select a0 d)  d0  byte move
    80 #  d0 byte and 
  0<> until
  rts

code retrace
  >fb l#)  a0  long move
  (retrace bsr
c;

\ move from: a0, to: a1, for: 300
\ a2: >fb

create (cmap-move assembler
  gr_sr_select l#  a2  long adda
  300 l#  d0  long move
  begin
    begin
      a2 )  d1  byte move
      80 #  d1  byte and
    0<> until
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    a0 )+  a1 )+  byte move
    8 d0 subq
  0= until
  next
forth

code cmap! ( >cmap --- )
  >fb l#)  a2  long move
  sp )+  a0  long move
  a2  a1  long move
  gr_red_cmap gr_update + l#  a1  long adda
  (cmap-move bra
c;

code cmap@ ( >cmap --- )
  >fb l#)  a2  long move
  a2  a0  long move
  gr_red_cmap gr_update + l#  a0  long adda
  sp )+  a1  long move
  (cmap-move bra
c;

create cmap 300 allot

: cmap.red
  cmap ;

: cmap.green
  cmap 100 + ;

: cmap.blue
  cmap 200 + ;

: scroll ( addr --- )
  dup c@ swap		\ c addr
  dup dup 1+ swap	\ c addr addr+1 addr
  ff cmove
  ff + c!
;

: scroll-cmap
  cmap.red scroll
  cmap.green scroll
  cmap.blue scroll
;

: cls
  fb_height 0 do
    i lineaddr fb_width erase
  loop
;

decimal