Hey, it's good. I just modified it to add 256 colours and improve the performance a bit. I'm also adding a bit of test code.
The modified code:
Rem Project: Dark Basic Pro Project
Rem Created: Tuesday, November 23, 2010
remstart
To the origin this source appeared in the
magazine ATARI ST (France) the code is of
François Schneider <Mega 1> coded in Gfa v3
I simplified it -not returned display 3D -
solely returned map in levels of colors
or grey.
This source is raw, you can easely modify it.
Excuse me for my bad translation in english
remend
Rem ***** Main Source File *****
set display mode 800,600,32
set window on
set window size 800,600
sync off
set text size 20
set text opaque
dimension= 2^12
DIM h(dimension,dimension)
DIM x3d(3)
dim y3d(3)
dim z3d(3)
dim xaff(3)
dim yaff(3)
dim encre(256)
CLS
create bitmap 1,800,600
set current bitmap 0
ink rgb(230,230,230),rgb(0,0,0)
gosub infoText
REPEAT
INPUT "Size of map (4-10) ?";niter
UNTIL niter => 4 AND niter <= 10
rem C'est ici que cela plantera si vous n'avez pas
rem un ordinateur avec une grosse carte graphique
if niter = 9 then create bitmap 1,1024,1024
if niter = 10 then create bitmap 1,2048,2048
gosub neufpremiers
depth = niter
gosub calcul
CLS
gosub initcoul1
depth = niter
gosub affcarte
set current bitmap 0
If niter = 9 then copy bitmap 1,0,0,1024,1024,0,0,0,512,512
if niter < 9 then copy bitmap 1,0,0,taille,taille,0,0,0,taille,taille
rem name of the bitmap in 15 colors
sav_img$ ="mapA.BMP"
DO
ink rgb(230,230,0),rgb(0,0,0)
text 540,100,"Save BMP (Y/N) ?"
text 540,130,"name: " + sav_img$
text 540,160," Texture Map <Q> "
text 540,190," Height Map <G> "
if niter = 9
text 540,220,"Reduced picture for display"
endif
gris = 0
set cursor 540,250
text 540,250," "
text 540,500," "
input "?: ";choi$
choi$=upper$(choi$)
if choi$ = "Y"
save image sav_img$,1
ENDIF
if choi$ = "N"
delete bitmap 1
BREAK
END
ENDIF
if choi$ = "Q"
sav_img$ = "MAPA.BMP"
endif
if choi$ = "G"
text 540,500,"Wait please ..."
gris = 256
depth = niter
sav_img$ = "MAPB.BMP"
gosub affcarte
set current bitmap 0
ENDIF
LOOP
rem choice of colors for style geographic map
initcoul1:
create bitmap 2,256,10
box 0,0,150,10,rgb(0,100,0),rgb(0,100,0),rgb(100,100,0),rgb(100,100,0)
box 150,0,220,10,rgb(100,100,0),rgb(100,100,0),rgb(255,255,255),rgb(255,255,255)
box 220,0,256,10,rgb(255,255,255),rgb(255,255,255),rgb(255,255,255),rgb(255,255,255)
for col=1 to 256
red=rgbr(point(col,5))
green=rgbg(point(col,5))
blue=rgbb(point(col,5))
encre(col)=rgb(red,green,blue)
next col
set current bitmap 1
RETURN
Rem j'ai changé les PROCEDURE Gfa en gosub en DBPro
neufpremiers:
LOCAL i,j
PRINT " a(0,0) a(1,0) a(2,0)"
PRINT " a(0,1) a(1,1) a(2,1)"
PRINT " a(0,2) a(1,2) a(2,2)"
print
PRINT "Enter the altitudes of these points"
PRINT "( between -128 et 256)"
FOR j = 0 TO 2
FOR i = 0 TO 2
PRINT "altitude of (";i;",";j;")>";
INPUT h(i,j)
NEXT i
NEXT j
RETURN
rem en principe en GFA calcul(niter%) = PROCEDURE
calcul:
LOCAL amp,n,i,j
amp = 256
n = 2
PRINT " Iterations;";
FOR iter=1 TO depth
PRINT iter;"..";
FOR j = n TO 0 step - 1
FOR i = n TO 0 step - 1
h(i *2,j *2)= h(i,j)
NEXT i
NEXT j
n = n *2
rem the dimension doubled
FOR j = 1 TO n -1 STEP 2
FOR i = 1 TO n -1 STEP 2
rem the points a(i,j) of index i even and j odd
rem has for altitude the averages of those of a(i,j-1) and a(i,j+1)
h(i-1,j)=(h(i-1,j-1)+h(i-1,j+1))/2
h(i -1,j)= h(i -1,j)+ INT( Rnd(amp)- amp / 2)
rem for i odd and j even, the altitude is the average
rem between those of a(i-1,j) et a(i+1,j)
h(i,j -1)=(h(i -1,j -1)+h(i + 1,j - 1)) / 2
h(i,j -1)= h(i,j -1) + INT( RND(amp)- amp / 2)
rem for i and j odds the altitude is the average
rem of the altitudes of the 4 points of coordinates even neighbors...
h(i,j)= h(i -1,j -1)+h(i -1,j +1)
h(i,j)= h(i,j) + h(i +1,j -1)+ h(i +1,j +1)
h(i,j)= h(i,j) / 4 + INT( RND(amp) - amp / 2)
rem this loop doesn't treat the new points
rem of the last column of the picture
NEXT i
NEXT j
FOR i = 1 TO n -1 STEP 2
rem We treat here the new points of the last
rem lign and of the last column
h(n,i)=(h(n,i-1)+h(n,i+1))/2+ INT( RND ( amp)- amp / 2)
h(i,n)=(h(i-1,n)+h(i+1,n))/2+ INT( RND ( amp)- amp / 2)
NEXT i
amp = amp / 2
rem We divide the amplitude by 2
NEXT iter
RETURN
affcarte:
LOCAL n,i,j
n= 2^(depth +1)
CLS
taille = n
TEXT 540,0,"FRActal MOuntain GENerator"
text 580,30,"total: "+str$(taille)+"pixels "
set current bitmap 1
lock pixels
FOR j =0 TO n
FOR i =0 TO n
if gris =0 then ink coul1(h(i,j)),rgb(0,0,0)
if gris = 256
height=h(i,j)
if height> 255 then height = 255
rem Many values less than zero = many level <sea>
if height < 1 then height = 0
rem it's a grey color
ink rgb(height,height,height),rgb(0,0,0)
endif
dot i,j
NEXT i
NEXT j
unlock pixels
get image 1,0,0,taille,taille
if taille > 512 then taille = 512
copy bitmap 1,0,0,taille,taille,0,0,0,taille,taille
rem wait key
RETURN
FUNCTION coul1(alt)
LOCAL coul
if alt>255 then alt=255
if alt<0 then alt=0
if alt>0
coul=encre(alt)
else
coul=rgb(0,0,255)
endif
ENDFUNCTION coul
infotext:
print
PRINT "*** FRAMOGEN *** par François Schneider <Mega 1> to the origin on ATARI ST (France)"
print " modification for Dark Basic by Arcadia "
Print
print "This program can make maps in <heightmap> type of fractals maps in levels"
print "of colors or greys, to start you must enter the number of iterations"
print "who give the size of the picture"
Print " ex: <4> =map of 32 pixels,... <8> = 512 pixels, <9> = 1024 pixels"
print
print " CAUTION ! "
Print "If our computer don't have performance in graphic card or memory"
print "avoid number great than <8> "
print
print "You must enter 9 values who display the germe of this <Heightmap> "
print
print
return
The test code:
load image "MapA.bmp",1000,1
load image "detailmap.bmp",2000,1
make object terrain 20
set terrain heightmap 20 ,"mapB.bmp"
set terrain scale 20 ,3,3,3
set terrain split 20 ,16
set terrain tiling 20 ,16
set terrain light 20 ,1,-1,0,1,1,1,0.5
set terrain texture 20 ,1000,2000
build terrain 20
position camera get terrain x size(20)/2,500,get terrain z size(20)/2
do
px#=camera position x()
pz#=camera position z()
py#=camera position y()
pangy#=camera angle y()
pangx#=camera angle x()
nspeed#=0.5
key=0
if keystate(17)=1
fspeed#=curvevalue(nspeed#,fspeed#,10)
else
fspeed#=curvevalue(0,fspeed#,10)
endif
if keystate(30)=1
lspeed#=curvevalue(nspeed#,lspeed#,10)
else
lspeed#=curvevalue(0,lspeed#,10)
endif
if keystate(31)=1
bspeed#=curvevalue(nspeed#,bspeed#,10)
else
bspeed#=curvevalue(0,bspeed#,10)
endif
if keystate(32)=1
rspeed#=curvevalue(nspeed#,rspeed#,10)
else
rspeed#=curvevalue(0,rspeed#,10)
endif
px#=newxvalue(px#,pangy#+90,rspeed#):pz#=newzvalue(pz#,pangy#+90,rspeed#)
px#=newxvalue(px#,pangy#,fspeed#):pz#=newzvalue(pz#,pangy#,fspeed#)
px#=newxvalue(px#,pangy#,-bspeed#):pz#=newzvalue(pz#,pangy#,-bspeed#)
px#=newxvalue(px#,pangy#-90,lspeed#):pz#=newzvalue(pz#,pangy#-90,lspeed#)
CameraAngleY# = WrapValue(pangy#+MousemoveX())
CameraAngleX# = WrapValue(pangx#+MousemoveY())
pangy#=CurveAngle(CameraAngleY#,OldCamAngleY#,5)
pangx#=CurveAngle(CameraAngleX#,OldCamAngleX#,5)
py#=get terrain ground height(20,px#,pz#)+8
rotate camera CameraAngleX#,CameraAngleY#,0
position camera px#,py#,pz#
update terrain 20
loop
There is no such thing as "Too Fast!"
