-> landscape test

OPT OSVERSION=39

CONST CWIDTH=256,CHEIGHT=128,CWSHIFT=8
CONST SCHEIGHT=CHEIGHT+20
CONST TEMPBUFS=CWIDTH*CHEIGHT/2,BUFS=CWIDTH*CHEIGHT,BUFM=$7FFF
CONST SXOFF=50,SYOFF=80

MODULE '*c2p4', '*screenmodereq_db', 'tools/exceptions', 'tools/scrbuffer',
       'intuition/screens', 'graphics/rastport', 'graphics/gfx',
       'intuition/intuition'

PROC main() HANDLE
  DEF dbs,scr=NIL:PTR TO screen,bm:PTR TO bitmap,win=NIL:PTR TO window,
      tbuf2,tbuf3,tbuf2b,tbuf3b,cbuf,dbuf,dbuf2,lsbuf,sigbit,sig,safe=TRUE,a,x=0,y=0,
      imsg:PTR TO intuimessage,temp
  IF (dbs:=openreqscreen(CWIDTH,SCHEIGHT,4,'bla'))=NIL THEN Raise()
  scr:=sb_GetScreen(dbs)
  IF (win:=OpenW(0,0,CWIDTH-1,SCHEIGHT-1,
    IDCMP_MOUSEBUTTONS OR IDCMP_MOUSEMOVE,
    WFLG_REPORTMOUSE OR WFLG_BORDERLESS OR WFLG_SIMPLE_REFRESH OR WFLG_BACKDROP OR WFLG_ACTIVATE,
    '',scr,15,NIL))=NIL THEN Raise("WIN")
  tbuf2:=NewM(TEMPBUFS+TEMPBUFS,2)
  tbuf3:=tbuf2+TEMPBUFS
  tbuf2b:=NewM(TEMPBUFS+TEMPBUFS,2)
  tbuf3b:=tbuf2b+TEMPBUFS
  NEW cbuf[BUFS]
  NEW dbuf[BUFS]
  NEW dbuf2[BUFS]
  NEW lsbuf[BUFS]
  FOR a:=0 TO BUFS-1
    dbuf[a]:=-1
    dbuf2[a]:=-1
  ENDFOR
  FOR a:=0 TO 15 DO SetColour(scr,15-a,a*16,a*16,a*16)
  mountain(cbuf)
  CopyMem(cbuf,lsbuf,BUFS)
  SetRast(scr.rastport,0)
  IF (sigbit:=AllocSignal(-1))<>-1
    sig:=Shl(1,sigbit)
    REPEAT
      render(cbuf,lsbuf,CWIDTH*y+x,80,80)
      x:=x+2
      y:=y+3
      IF safe=FALSE
        Wait(sig)
        safe:=TRUE
      ENDIF
      bm:=sb_NextBuffer(dbs)
      ->SetColour(scr,15,f:=255-f,f,f)
      c2p4(tbuf3,tbuf2,cbuf,dbuf,bm.planes,FindTask(NIL),sig,gfxbase)
      temp:=dbuf; dbuf:=dbuf2; dbuf2:=temp
      temp:=tbuf2; tbuf2:=tbuf2b; tbuf2b:=temp
      temp:=tbuf3; tbuf3:=tbuf3b; tbuf3b:=temp
      IF imsg:=GetMsg(win.userport)
        x:=0-imsg.mousex
        y:=0-imsg.mousey
        ReplyMsg(imsg)
      ENDIF
      safe:=FALSE
    UNTIL Mouse()
    IF safe=FALSE THEN Wait(sig)
    FreeSignal(sigbit)
  ENDIF
EXCEPT DO
  IF win THEN CloseWindow(win)
  closereqscreen(dbs)
  SELECT exception
    CASE "SCR"; WriteF('no screen!\n')
    CASE "REQ"; WriteF('Error: Could not allocate ASL request\n')
    CASE "ASL"; WriteF('Error: Could not open ASL library\n')
  ENDSELECT
  report_exception()
ENDPROC

PROC mountain(buf)
  DEF a,x,y
  FOR a:=0 TO BUFS-1
    y:=a/CWIDTH; x:=Mod(a,CWIDTH)
    buf[a]:=Bounds(
       ((x-128)*(x-128))+((y-64)*(y-64))/300,
       ->x*y/300,
       ->!(!Fsin(x!/10.0)*3.0+3.0)+(!Fsin(y!/10.0)*3.0+3.0)!,
       ->!Fsin(x!/10.0)*6.0*Fsin(y!/10.0)+5.0!,
       0,15)
  ENDFOR
ENDPROC

PROC render(destbuf,lsbuf,offs,xs,ys)
  DEF a,t1,t2
  clearmem(destbuf,BUFS)
  t1:=ys-1*CWIDTH-1+offs
  t2:=xs-1+offs
  FOR a:=1 TO xs DO line(a,t1+a AND BUFM,a+SXOFF,a/2+SYOFF,destbuf,lsbuf)
  FOR a:=ys-1 TO 1 STEP -1 DO line(a,a-1*CWIDTH+t2 AND BUFM,xs*2+SXOFF-a,a/2+SYOFF,destbuf,lsbuf)
ENDPROC

PROC clearmem(mem,size)
  DEF e:REG,a:REG,b:REG,c:REG,d:REG
  e:=size/16-1
  a:=b:=c:=d:=$04040404
  MOVE.L mem,A0
  ADD.L size,A0
clloop:
  MOVEM.L a/b/c/d,-(A0)
  DBRA e,clloop
ENDPROC

PROC line(num,start,sx,sy,destbuf,lsbuf)
  DEF a:REG,y,t:REG,c=0:REG,xoff:REG,yoff:REG
  xoff:=sx+destbuf
  yoff:=sy-25-num+1
  y:=sy*CWIDTH+xoff
  a:=num-1+yoff
  MOVE.L start,D2		-> D2=start
  MOVEA.L lsbuf,A3		-> A3=lsbuf
  MOVE.L y,A2			-> A2=y
  MOVE.L #CWIDTH,D1		-> D1=CWIDTH
  MOVE.L #BUFM,D0		-> D0=BUFM
  MOVE.L #CWIDTH+1,A1		-> A1=CWIDTH+1
bloop:				-> this loop eats almost all cpu-time.
  MOVE.B 0(A3,D2.L),c
  MOVE.L a,t
  ADD.L c,t
  LSL.L #CWSHIFT,t
  ADD.L xoff,t
  CMP.L A2,t
  BGE.S skip
  BRA.S loop
begi:
  SUBA.L D1,A2
  MOVE.B c,(A2)
loop:
  CMP.L A2,t
  BMI.S begi
skip:
  SUB.L A1,D2
  AND.L D0,D2
  SUBQ.L #1,a
  CMP.L yoff,a
  BPL.S bloop
ENDPROC