darkbasic classic and warrenview

Years ago, there was this cool program called warrenview which would display pictures as a 3d plane that you could rotate around. I had a cd of darkbasic classic and decided to install it and start fiddling around. It's very idiosyncratic but it's fast and fun and a bit addictive to try things out and see what happens. I remember the old Amiga AMOS Basic and DarkBasic Classic (DBC) reminds me of it. It can be fiddly to get things working but it doesn't seem to crash.

DBC is a bit archaic (the built in editor is 640x480 even if you have a full HD monitor). PRINT doesn't scroll the screen when you hit the bottom of the screen or use a monospace font. Once you activate the 3d system it will tend to overwrite everything on the screen unless you disable the background with BACKDROP OFF. You can set things but not retrieve the same state, like SCALE TEXTURE. It's a one way street with write only and you have to remember what you set it to.

If you want to write text to the screen, the automatic refreshing system will overwrite it unless you refresh it every 60th of a second even when you use SYNC ON and SYNC. Putting in a WAIT 5000 or SLEEP 5000 will have the text disappear within the next 60th of a second.

Why do comments have to start with a backtick? Why not a single quote like QBASIC? (That one is hardwired, man! Must unlearn...)

And my personal favorite, when the editor is running (just editing your program, not running a program), cpu usage is 100%. (Why Lisa, why?)

Anyway, here's my attempt at recreating warrenview in DBC. There's something really satisfying about spinning the picture with the mouse at 60 fps.

`DARKBASIC WARRENVIEW
` 8/31/2018
`
`I liked the program WarrenView and wanted to see if
`dark basic classic could load pictures and view them as a 3d plane
`

sync rate 0
`If I toggle set window, the darkbasic screen will only take up a single
`monitor at 640x480 and not get hung up on my horizontal multimonitor span
set window on
set window off

make light 1
POSITION LIGHT 1,0,0,-20
COLOR LIGHT 1,255,255,255
POINT LIGHT 1,0,0,0


makebitmapcross(20,1024,1024)
set camera range 1,6000
print bitmap width(20),bitmap height(20)
`sleep 2000
set current bitmap 20

for i = 0 to bitmap width(20) step 20
intval = int(real#(bitmap width(20)-i)/real#(bitmap width(20))*255.0)
ink rgb(intval,intval,intval),0
`for xoff=0 to 2
`lineb(i,0,i,bitmap height(20))
`lineb(i+xoff,0,i+xoff,bitmap height(20))
`next xoff
`ink rgb(255,255,255),0
BOX i,0,i+4,bitmap height(20)-1
`ok box fails if you have the coordinates off of the screen
`must be WITHIN, ie bitmap height(20)-1
`print i,0,i+4,bitmap height(20)
ink rgb(255,255,255),0
set current bitmap 0
printc "."
printc intval
set current bitmap 20
next i


set text size 25.0*(bitmap width(20)/640)

ink rgb(0,0,0),0
drawstring$="BITMAP "+STR$(bitmap width(20))+"x"+str$(bitmap height(20))
baseline=5
box 10,10+baseline,10+text width(drawstring$),10+25.0*(bitmap width(20)/640)+baseline+2
ink rgb(255,255,255),0
text 10,10,drawstring$
`text 10,10,"BITMAP "+STR$(width)+"x"+str$(height)


set cursor 50,100
set text opaque
set text size 8
text 50,100,"Can I read this font?"
text 50,115,"Generated on"+get date$()+ " "+get time$()
set text transparent
`print "Can I read this font?"

get image 20,0,0,bitmap width(20),bitmap height(20)
set current bitmap 0
make object plain 20,bitmap width(20),bitmap height(20)
texture object 20,20
`autocam on



`position camera 0,0,(-(bitmap width(2))-(bitmap height(2)))
width = bitmap width(20)
height = bitmap height(20)
position camera 0,0,0-width
point camera 0,0,0

ROTATEKEYSNUM(20)

gosub readdirectory


`draw the file list onto our bitmap

set current bitmap 20
set text opaque
t=0
text 5*20,(10+t)*25,"Picture Files in "+get dir$()+"\"
for t = 1 to piccount
ink rgb(128,255,255),0
text 5*20,(10+t)*25,"FILE "+str$(t)+":"+picitems$(t)
next t


`draw the instructions onto our bitmap

linepos = 15
set current bitmap 20
set text opaque
ink rgb(255,255,150),0
text 60*10,(linepos)*25,"INSTRUCTIONS:" : inc linepos
text 60*10,(linepos)*25,"Press PageUp for previous picture" : inc linepos
text 60*10,(linepos)*25,"Press PageDown for next picture" : inc linepos
text 60*10,(linepos)*25,"Press T/Y to set transparency on/off" : inc linepos
text 60*10,(linepos)*25,"Press A/S to scale texture up/down" : inc linepos
text 60*10,(linepos)*25,"Press G/H to set ghost mode on/off" : inc linepos
text 60*10,(linepos)*25,"Press W/E to set wireframe on/off" : inc linepos
text 60*10,(linepos)*25,"Press B/N to set bilinear filtering on/off" : inc linepos
text 60*10,(linepos)*25,"Press T/Y to set transparency on/off" : inc linepos
text 60*10,(linepos)*25,"Press Z/X to spin image on/off" : inc linepos
text 60*10,(linepos)*25,"Press Return to reset image" : inc linepos
text 60*10,(linepos)*25,"Press Shift to spin on Z axis" : inc linepos
text 60*10,(linepos)*25,"Roll mouse wheel to zoom in/out" : inc linepos
text 60*10,(linepos)*25,"Press TAB to save screenshot" : inc linepos
text 60*10,(linepos)*25,"Press Insert for infinite mirrors effect" : inc linepos


wireframe=1
transparency=1
bilinear=1

get image 20,0,0,bitmap width(20),bitmap height(20)
texture object 20,20

save bitmap "MYCROSS1024.BMP",20
`sleep 1000

currentpic=0
`if piccount>=1 then currentpic=1

if currentpic <> 0 
  if currentpic > piccount then currentpic=1
  if currentpic < 1 then currentpic=piccount
  loadbitmapimage(picitems$(currentpic),20,20)
  texture object 20,20
endif
remend

sync on
mousemovezorigin=mousemovez()


scale#=1
newscale#=scale#
gosub changetexscale


do
rotatekeysnum(20)


cull=0
`if you want to cull, then cull=1

objectnum=20

SET OBJECT objectnum,wireframe,transparency,cull,bilinear

if scancode()=5 then SET OBJECT objectnum,1,0,0
if keystate(6) then SET OBJECT objectnum,1,1,0,1

IF UPPER$(INKEY$())="T" THEN transparency=0
IF UPPER$(INKEY$())="Y" THEN transparency=1

IF UPPER$(INKEY$())="B" THEN bilinear=1
IF UPPER$(INKEY$())="N" THEN bilinear=0

IF UPPER$(INKEY$())="W" THEN wireframe=0
IF UPPER$(INKEY$())="E" THEN wireframe=1

IF UPPER$(INKEY$())="G" THEN GHOST OBJECT ON objectnum
IF UPPER$(INKEY$())="H" THEN GHOST OBJECT OFF objectnum

IF UPPER$(INKEY$())="Z" THEN spinx = 1
IF UPPER$(INKEY$())="X" THEN spinx = 0

if spinx then YROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE Y(objectnum)-1)


if keystate(15) then save bitmap "WARREN_SCREENSHOT.PNG"

`insert key for infinite mirrors effect
if keystate(210) then GET IMAGE 20,0,0,BITMAP WIDTH(0),BITMAP HEIGHT(0) : TEXTURE OBJECT 20,20 : text 0,80,"INSERT KEY"
`weird, once I put it into transparent mode, the insert key stops working?


if keystate(209)
  if pgdowndelay < 1
  currentpic=currentpic+1 : if currentpic > piccount then currentpic=1
  loadbitmapimage(picitems$(currentpic),20,20)
  texture object 20,20
  pgdowndelay=30
  else
   dec pgdowndelay
  endif
else 
`key is up so reset delay
  pgdowndelay=0
endif
if keystate(201) 
  if pgupdelay < 1
    currentpic=currentpic-1 : if currentpic < 1 then currentpic=piccount
    loadbitmapimage(picitems$(currentpic),20,20)
    texture object 20,20
    pgupdelay = 30
  else
    dec pgupdelay
  endif
else
  pgupdelay=0
endif

position camera camera position x(),camera position y(), (camera position z() + (mousemovez() - mousemovezorigin))
text 400,0,"CAMERA Z="+str$(camera position z())+" "+str$(mousemovez() - mousemovezorigin)
mousemovezorigin=mousemovez()

texspeed#=0.02
if upper$(inkey$())="A" then newscale#=maxreal#(scale#-texspeed#,1.0) :  gosub changetexscale 
if upper$(inkey$())="S" then newscale#=minreal#(scale#+texspeed#,10.0) : gosub changetexscale

if spacekey() then exit

text 0,30,str$(currentpic)+" of "+str$(piccount)
loop


end

`========= SUBROUTINES

readdirectory:

rem Find current directory
mydir$=get dir$()

rem Current directory can also be changed
set dir mydir$

rem Show user current directory
print "Directory to scan is ";mydir$

find first

dim diritems$(100)
dim picitems$(100)
piccount=0
itemcount=1

repeat
if get file type()=0
  diritems$(itemcount)=get file name$()
  itemcount=itemcount+1
endif
find next
until get file type()=-1

set current bitmap 0
backdrop off
cls
print "Files in current directory:"
sync on
sync
cls
draw to front
for t=1 to itemcount-1
print "FILE ",t,": ",diritems$(t)
if upper$(right$(diritems$(t),4))=".JPG" then print "JPEG" : piccount = piccount+1:picitems$(piccount)=diritems$(t)
if upper$(right$(diritems$(t),4))=".BMP" then print "BMP"  : piccount = piccount+1:picitems$(piccount)=diritems$(t)
if upper$(right$(diritems$(t),4))=".PNG" then print "PNG"  : piccount = piccount+1:picitems$(piccount)=diritems$(t)
next t
`sleep 4000
RETURN



changetexscale:
scale object texture 20,newscale#/scale#,newscale#/scale#
scale#=newscale#
return

doodles:
backdrop off
cls
print "You can do a gosub from the command line interface"
print " for example: type 'gosub doodles'"
return

END



function makebitmapcross(bitmapnum,width,height)
if bitmap exist(bitmapnum) then delete bitmap bitmapnum
create bitmap bitmapnum,width,height
set current bitmap bitmapnum
set text size 25.0*(width/640)
ink rgb(255,255,255),0
text 10,10,"BITMAP "+STR$(width)+"x"+str$(height)
borderthick = 4
for xoff=0 to borderthick*(width/640)
for yoff=0 to borderthick*(width/640)
lineb(xoff,yoff,width-xoff,height-yoff)
lineb(xoff+width/2,yoff,width-xoff+width/2,height-yoff)
lineb(xoff,yoff+height/2,width-xoff,height-yoff-height/2)
next yoff
next xoff
set current bitmap 0
endfunction


FUNCTION LINEB(X1,Y1,X2,Y2)
`draw a box, like qbasic line with the B parameter
LINE X1,Y1,X2,Y1
LINE X2,Y1,X2,Y2
LINE X2,Y2,X1,Y2
LINE X1,Y2,X1,Y1
ENDFUNCTION


`from the CLI you can type this:
`
` repeat : rotatekeysnum(20) : until shiftkey()
`
` or you can type this:
`
` do : rotatekeysnum(20) : loop


FUNCTION ROTATEKEYSNUM(objectnum)

backdrop on
ink rgb(255,255,255),0
IF UPKEY() THEN XROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE X(objectnum)+1)
IF DOWNKEY() THEN XROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE X(objectnum)-1)
IF LEFTKEY() THEN YROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE Y(objectnum)+1)
IF RIGHTKEY() THEN YROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE Y(objectnum)-1)
IF SPACEKEY() THEN EXITFUNCTION
if scancode()=2 then sync rate 60
if scancode()=3 then sync rate 120
IF SCANCODE()=4 THEN sync rate 0
if keystate(201) then text 0,200,"PGUP"
if keystate(209) then text 0,200,"PGDOWN"

if returnkey() 
  position object objectnum,0,0,0
  rotate object objectnum,0,0,0
  position camera 0,0,0-bitmap width(20)
endif

IF MOUSECLICK()>0
   POSITION OBJECT objectnum,object position x(objectnum)+mousemovex()*2,object position y(objectnum)-mousemovey()*2,object position z(objectnum)
ELSE

if shiftkey() = 0 and controlkey() = 0
XROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE X(objectnum)-MOUSEMOVEY())
YROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE Y(objectnum)-MOUSEMOVEX())
else
XROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE X(objectnum)-MOUSEMOVEY())
ZROTATE OBJECT objectnum,WRAPVALUE(OBJECT ANGLE Z(objectnum)-MOUSEMOVEX())
endif
ENDIF

SYNC
DRAW TO FRONT
set current bitmap 0
SET TEXT SIZE 14
SET TEXT FONT "Arial"
TEXT 0,0,"FPS="+STR$(SCREEN FPS())+ " MouseMoveZ = "+str$(mousemovez())
ENDFUNCTION


function CLEARLINE(LINE)
ink rgb(0,0,0),0
box 0,LINE*16,639,(LINE+1)*16-1
ink rgb(255,255,255),0
ENDFUNCTION

function LOCATE(LINE,POS)
set cursor pos*7,LINE*16
endFUNCTION

function loadbitmapimage(filename$,bitmapnum,imagenum)
if bitmap exist(bitmapnum) then delete bitmap bitmapnum
load bitmap filename$,bitmapnum
`this autosizes the bitmap to the loaded image
set current bitmap bitmapnum
`draw some stuff on the bitmap like the filename and the size of the image
set text font "Arial"
set text size 20*1.0*(bitmap width(bitmapnum))/640.0
drawstring$="FILE="+filename$+"  "+"SIZE ="+str$(bitmap width(bitmapnum))+"x"+str$(bitmap height(bitmapnum))
`draw a black outline for the text
x=10
y=10
bordthick=max(int(3.0*scalefactor#*(bitmap width(bitmapnum))/640.0),1)
for xoff=0-bordthick to bordthick
for yoff=0-bordthick to bordthick
ink rgb(0,0,0),0
text x+xoff,y+yoff,drawstring$
next yoff
next xoff
`draw the white inner part for the text
ink rgb(255,255,255),0
text x,y,drawstring$
get image imagenum,0,0,bitmap width(bitmapnum),bitmap height(bitmapnum)
set current bitmap 0
`some debugging stuff
`backdrop off
`cls
`print filename$
`wait 2000
`backdrop on
endfunction




function sc()
`quick and dirty to get a scancode
`run, hit esc and then sc
backdrop off:sync on :SET CAMERA VIEW 320,200,420,300
DO
SET CURSOR 0,0
CLEARLINE(0)
PRINT "INKEY='",INKEY$(),"' SCANCODE=",SCANCODE()
SLEEP 1000
LOOP
endfunction

function min(a,b)
retval=a
if b<a then retval=b
endfunction retval

function max(a,b)
retval=a
if b>a then retval=b
endfunction retval

function minreal#(a#,b#)
retval#=a#
if b#<a# then retval#=b#
endfunction retval#

function maxreal#(a#,b#)
retval#=a#
if b#>a# then retval#=b#
endfunction retval#

function makereal#(a)
retval#=a
endfunction retval#

`function to convert an integer to a real
function real#(a)
retval#=a
endfunction retval#