[WIP]RPG like 2D map generator for PiSTARTER

make2DMap.prg

'
' 2Dマップジェネレーター
'
option strict

acls
var SW=1280,SH=720,xScale=2
xscreen sw,sh
var CX=SW/2,CY=SH/2
VAR VRAMW=1280,VRAMH=1024

VAR VER$="1.00"

var chr_umi     =147
var chr_yama    =101
var chr_ki      =100
var chr_kusa    =99
var chr_heiya   =97


'パーリンノイズ関係
var grid=128
dim parlinPtn[grid*4+1,grid*4+1]
var gridCenter=grid*2
var octaveMin=2
var octaveMax=5
octaveMax=6
'octaveMax=2

'地形データ
var mapW=256,mapH=256
dim map[mapW,mapH]
dim mapCol[mapW,mapH]
dim bgmap[mapW,mapH]
var mapMag=1/1 '地形マップの表示倍率
var mapOX=SW-mapW*mapMag,mapOY=0 '地形マップの表示位置

'地形パラメータ。生成される地面の高度(-0.5～0.5)の扱いを決める
VAR plain=0.03          '平地の基準高度
VAR plainMax=plain+0.25 '平地の最大高度。plain～plainMaxの地面を平地として平らにする。
var sea=plain-0.02      '海面の基準高度。これより低い地面は海とみなす。
var tall=48             '描画時の高さの倍率。大きくすると山が高くなる。
var tmag=(1-plain)/(1-plainMax)

var sp_map=0
var sp_csr=1
var sp_chr=2
var sp_black=512-6
var sp_dbg=512-5
var bgchrPage=1
load "grp1:/IMAGE/SMILEBOOM/DEFBG.png"

'gpage 0,sppage():gcls #black:gpage 0,0
prepareDebug
createPerlinPattern
createWorld
createMap
viewMap
end

def prepareDebug
 spset sp_dbg,0,0,1280,1024,1
 spcolor sp_dbg,rgb(255,255,255,255)
 var scl=0.3
 spscale sp_dbg,scl,scl
 spofs sp_dbg,sw-1280*scl,sh-1024*scl

 gfill 31*16,31*16,31*16+15,31*16+15,#black
 spset sp_black,31*16+8,31*16+8,1,1,1
 spscale sp_black,1280*scl,1024*scl
 spofs sp_black,sw-1280*scl,sh-1024*scl
end

def viewMap
 gcls
 var scrW=((SW/xScale) div 16)*mapMag
 var scrH=((SH/xScale) div 16)*mapMag
 var ox=256,oy=512
 spset sp_csr,ox,oy,scrW,scrH,1
 gpage 0,sppage()
 gfill ox,oy,ox+scrW-1,oy+scrH-1,#red
 var border=2
 gfill ox+border,oy+border,ox+scrW-1-border,oy+scrH-1-border,0
 gpage 0,0
 
 spset sp_chr,522
 sphome sp_chr,8,8
 spscale sp_chr,2,2
 spofs sp_chr,cx,cy
 spanim sp_chr,"I", 15,520, 15,521, 15,522, 15,523, 0
 
 BGSCREEN mapW,mapH
 BGLOAD bgmap,mapW,mapH
 var x=0,y=0,spd=8,sx,sy,worldW=mapW*16,worldH=mapH*16
 while 1
  stick out sx,sy
  inc x,(button(0,#bid_right)-button(0,#bid_left))*spd+sx*2
  inc y,(button(0,#bid_down)-button(0,#bid_up))*spd+sy*2
  bgofs x,y
  var mx=(((x+worldW) mod worldW) +worldW) mod worldW
  var my=(((y+worldH) mod worldH) +worldH) mod worldH
  spofs sp_csr,mapOX+mx/16*mapMag,mapOY+my/16*mapMag
  vsync
 wend
end

def createPerlinPattern
 var x,y,gradU=1,gradV=0

 for y=-grid to grid
  var v=y/grid
  var fv=1-fad(abs(v))

  for x=-grid to grid
   var u=x/grid
   var fu=1-fad(abs(u))

   var c=(u*gradU+v*gradV)*fu*fv
   parlinPtn[gridCenter+x,gridCenter+y]=c
  next
 next
end

def fad(t)
 return t*t*t*(t*(t*6-15)+10)
end

def createWorld
 width 16
 color #LIME

 'パーリンパターンからマップを生成
 fill map,0
 locate 0,(SH div 16)-1
 var o
 for o=octaveMin to octaveMax
  var oct=pow(2,o-1),amp=pow(2,o-octaveMin)
  ?format$("Octave=%d(x%D) Amp=1/%d",o,oct,amp)
  makeMap 1/oct,1/amp
 next
 cls

 'マップの高度から地形を作成
 var i,j
 for j=0 to mapH-1
  for i=0 to mapW-1
   var t=map[i,j] 't=-0.5〜0.5
   '平野を作る
   if t>plain then t=plain+max(0,t-plainMax)*tmag
   '海面を作る
   t=max(t,sea)
   map[i,j]=t
  next
 next

 for j=0 to mapH-1
  for i=0 to mapW-1
   var i1=(i+1) mod mapW
   var j1=(j+1) mod mapH
   t=max(map[i,j],map[i1,j],map[i1,j1],map[i,j1])

   '色を設定 h: 青(0) 緑(100) 黄(200)
   var h=100+(t-plain)*300
   'h=(h div 30)*30
   var b=0.8
   if t<=sea then h=10:b=0.7 '海

   '色を少しランダムにする
   randomize 1,i+j*mapH
   dec h,rnd(1,10)-5
   mapCol[i,j]=byg2rgb(h,b)

   var ch=chr_umi
   if t>sea then
    ch=chr_heiya
    if rnd(100)<5 then ch=chr_kusa
   endif
   if t>plain then ch=chr_ki
   if t>plain+0.2 then ch=chr_yama
   bgmap[i,j]=ch
  next
 next
end

'1オクターブ分の重ね合わせを行う
def makeMap scl,amp
 var ix,iy,stp=grid*scl
 for iy=0 to mapH-1 step stp
  for ix=0 to mapW-1 step stp
   rotDraw ix,iy,scl,rad(rnd(360)),amp
  next
 next
end

'1パターン分の重ね合わせを行う
def rotDraw x,y,scl,th,amp
 var u,v,size=grid*scl

 for v=-size to size
  for u=-size to size
   var px=gridCenter+(u*cos(th)-v*sin(th))/scl
   var py=gridCenter+(u*sin(th)+v*cos(th))/scl
   if px<0 || py<0 || px>grid*4 || py>grid*4 then continue

   var gx=(x+u+mapW) mod mapW
   var gy=(y-v+mapH) mod mapH
   inc map[gx,gy],parlinPtn[px,py]*amp

   var c=(1+map[gx,gy])*128
   gpset gx,gy,rgb(c,c,c)
  next
 next
end

def byg2rgb(h,v)
 'h=0〜200
 var hh=h*510/200
 var r=hh-255
 var g=hh
 var b=255-hh
 return rgb(r*v,g*v,b*v)
end

def createMap
 var ox=0,oy=512 'マップのオフセット
 gpage 0,SPPAGE()
 var i,j,stp=1/mapMag
 for j=0 to mapH-1 step stp
  for i=0 to mapW-1 step stp
   gpset ox+i*mapMag,oy+j*mapMag,mapCol[i,j]
  next
 next
 spset sp_map,ox,oy,mapW/stp,mapH/stp,1
 spofs sp_map,mapOX,mapOY
 spcolor sp_map,rgb(192,255,255,255)
 gpage 0,0
end

def waitKey
 repeat:vsync:until inkey$()!=""
end


'============================================
'BG func
'============================================
var bgW,bgH,bgVramW,bgVramH
dim bgVram%[0],bgScreen%[0]
var bgOx,bgOy
var bgOfsU,bgOfsV
var sp_bg,z_bg

'BGSCREEN
'--------------------------------------------
def BGSCREEN w,h
 sp_bg=512-4
 z_bg=1023

 bgW=w:bgH=h
 dim t1%[bgW*bgW]:bgScreen%=t1%
 BGRESIZE w,h
end

'BGRESIZE
'--------------------------------------------
def BGRESIZE w,h
 if bgVramW!=0 then
  var vp,wp:gpage out vp,wp:gpage vp,sppage()
  gfill bgOfsU,bgOfsV,bgOfsU+bgVramW*16-1,bgOfsV+bgVramH*16-1,0
  gpage vp,wp
 endif

 bgVramW=ceil(sw/xScale / 16)+1
 bgVramH=ceil(sh/xScale / 16)+1

 dim t2%[bgVramW*bgVramH]:bgVram%=t2%
 fill bgVram%,-1

 'bgOfsU=1280-bgVramW*16:bgOfsV=1024-bgVramH*16
 bgOfsU=512:bgOfsV=0
 bgOx=-999:bgOy=-999
end

'BGLOAD
'--------------------------------------------
def BGLOAD M,mw,mh
 var w=min(bgW,mw)
 var h=min(bgH,mh)
 var x,y
 for y=0 to h-1
  for x=0 to w-1
   bgScreen%[y*bgW+x]=M[x,y]
  next
 next
end

'BGPUT
'--------------------------------------------
def BGPUT x,y,ch
 if x<0 || y<0 || x>=bgW || y>=bgH then return
 bgScreen%[y*bgW+x]=ch
end

'BGGET
'--------------------------------------------
def BGGET(x,y)
 if x<0 || y<0 || x>=bgW || y>=bgH then return -1
 return bgScreen%[y*bgW+x]
end


'BGOFS
'--------------------------------------------
def BGOFS bx,by
 var vw=bgVramW*16,vh=bgVramH*16

 var ox=floor(bx/16)
 var oy=floor(by/16)

 var sp=sp_bg
 var u=((bx mod vw)+vw) mod vw,v=((by mod vh)+vh) mod vh
 var w=vw-u,h=vh-v
 if !spused(sp) then
  spset sp+0,bgOfsU+u,bgOfsV+v,   w,   h:spOfsScale sp+0,0,0,z_bg
  spset sp+1,bgOfsU+0,bgOfsV+v,vw-w,   h:spOfsScale sp+1,w,0,z_bg
  spset sp+2,bgOfsU+u,bgOfsV+0,   w,vh-h:spOfsScale sp+2,0,h,z_bg
  spset sp+3,bgOfsU+0,bgOfsV+0,vw-w,vh-h:spOfsScale sp+3,w,h,z_bg
 else
  spchr sp+0,bgOfsU+u,bgOfsV+v,   w,   h:spOfsScale sp+0,0,0,z_bg
  spchr sp+1,bgOfsU+0,bgOfsV+v,vw-w,   h:spOfsScale sp+1,w,0,z_bg
  spchr sp+2,bgOfsU+u,bgOfsV+0,   w,vh-h:spOfsScale sp+2,0,h,z_bg
  spchr sp+3,bgOfsU+0,bgOfsV+0,vw-w,vh-h:spOfsScale sp+3,w,h,z_bg
 endif

 var vp,wp:gpage out vp,wp:gpage vp,sppage()

 var x,y,x1,x2,y1,y2,vCh,sCh,gx,gy,cx,cy,ptr

 if bgOx!=ox then
  '前回とX方向のマス目が変わった
  if ox<bgOx then
   x1=ox
   x2=min(bgOx-1,ox+bgVramW-1)
  else
   x1=max(bgOx+bgVramW,ox)
   x2=ox+bgVramW-1
  endif
  y1=oy:y2=oy+bgVramH-1
  bgRefresh x1,y1,x2,y2
 endif

 if bgOy!=oy then
  '前回とY方向のマス目が変わった
  if oy<bgOy then
   y1=oy
   y2=min(bgOy-1,oy+bgVramH-1)
  else
   y1=max(bgOy+bgVramH,oy)
   y2=oy+bgVramH-1
  endif
  x1=max(ox,bgOx)
  x2=min(ox,bgOx)+bgVramW-1
  bgRefresh x1,y1,x2,y2
 endif

 bgOx=ox:bgOy=oy 
 gpage vp,wp
end

'必要なエリアのみ描画
def bgRefresh x1,y1,x2,y2
 var x,y
 for y=y1 to y2
  for x=x1 to x2
   var xx=((x mod bgVramW)+bgVramW) mod bgVramW
   var yy=((y mod bgVramH)+bgVramH) mod bgVramH
   var ptr=yy*bgVramW+xx
   var vCh=bgVram%[ptr]
   var sCh=0
   
   var bgx=((x mod bgW)+bgW) mod bgW
   var bgy=((y mod bgH)+bgH) mod bgH
   'if y>=0 && y<bgH && x>=0 && x<bgW then sCh=bgScreen%[y*bgW+x]
   sCh=bgScreen%[bgy*bgW+bgx]
   if vCH!=sCH then
    var gx=bgOfsU+xx*16
    var gy=bgOfsV+yy*16
    var cx=(sCh mod 32)*16,cy=(sCh div 32)*16
    gcopy bgchrPage,cx,cy,cx+15,cy+15,gx,gy,1
    bgVram%[ptr]=sCh
   endif
  next
 next
end

'拡大率付きスプライト表示
def spOfsScale sp,x,y,z
 if spused(sp) then
  spofs sp,x*xScale,y*xScale,z
  spscale sp,xScale,xScale
 endif
end