FreeBASIC マニュアルのトップに戻る

FreeBASIC rotating cube with texture

目次→フォーラム→FreeBASIC→補足rotating cube with texture←オリジナル・サイト

織り柄の立方体を回転させる 左にメニュー・フレームが表示されていない場合は、ここをクリックして下さい

←リンク元に戻る プログラム開発関連に戻る

 このコードは、立方体の2面のみで織り柄の立体を、回転させます。

注:FreeBASIC 1.08〜 で、SetEnviron を追加しなくても、日本語環境で描画画面が表示されるように改善されました。
'rotating cube with texture
'by BasicCoder2 ≫ Nov 20, 2014 0:02 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=23053

' Sets the graphics method GDI
' 描画方法を GDI に設定
SetEnviron("fbgfx=GDI")

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

const ScrW = 1000
const ScrH = 600
screenres ScrW,ScrH,32
dim as integer wImg,hImg  'width and height of image
wImg = 256
hImg = 256

'=====  DODICAT IMAGE ===========
dim as any ptr image
image = imagecreate(wImg,hImg)
'draw something on image
For y As Integer=0 To hImg-1
    For x As Integer=0 To wImg-1
        Pset image,(x,y),Rgb(x,x Xor y,y)
    Next x
Next y
'===============================

Cls

type Point3D
    x as double
    y as double
    z as double
    c as uinteger
end type

type Point2D
    x as double
    y as double
    c as uinteger
end type

dim as Point3D e

e.x = 0
e.y = 300
e.z = 1000

dim as Point3D pt3D(24)

dim as double angle,x,y,z,rx,ry,rz,px,py
dim as double cosAngle,sinAngle
dim as uinteger c
    
for aRot as double = 0 to 360 step 5
    
    angle = aRot*DtoR
    
    cosAngle = cos(angle)
    sinAngle = sin(angle)
    
    screenlock()
    cls

    'draw bottom
    for j as integer = 0 to 255
        for i as integer = 0 to 255
            
            x = i-127
            y = 127
            z = j-127
            
            c = point(i,j,image)

            'rotate
            rx = (cosAngle *x) - (sinAngle * z)
            ry = y
            rz = (sinAngle * x) + (cosAngle * z)
            
            rx = rx - e.x
            ry = ry - e.y
            rz = rz - e.z
        
            'convert 3d to 2d coordinates
            px = (rx/rz) * ScrW + ScrW / 2
            py = (ry/rz) * ScrH + ScrH / 2

            pset (px,py),c
            
        next i
    next j
    
    'draw front side
    for j as integer = 0 to 255
        for i as integer = 0 to 255
            
            x = i-127
            y = j+127
            z = 127
            
            c = point(i,j,image)

            'rotate
            rx = (cos(Angle) *x) - (sin(Angle) * z)
            ry = y
            rz = (sin(Angle) * x) + (cos(Angle) * z)
            
            rx = rx - e.x
            ry = ry - e.y
            rz = rz - e.z
        
            'convert 3d to 2d coordinates
            px = (rx/rz) * ScrW + ScrW / 2
            py = (ry/rz) * ScrH + ScrH / 2

            line (px,py)-(px+1,py+1),c,bf
            
        next i
    next j

    locate 2,2
    print "angle of rotation =";aRot
    screenunlock()
    sleep 10        
    
next aRot
sleep
aaassasdfasdfasfdas

 以下は、上下2面が解放された立方体を回転させます。

'rotating cube with texture
'by dodicat ≫ Nov 21, 2014 0:13 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=23053

' Sets the graphics method GDI
' 描画方法を GDI に設定
SetEnviron("fbgfx=GDI")

Type v3
    As integer x,y,z
End Type

type float
    as single x,y,z
end type

Dim Shared As v3 eyepoint
 
Sub rotateImage(im As Any Ptr,angle As float,shift As V3,Byref centroid As V3,da as float)
    
    Dim  As Single dx,dy,dz=shift.z,w
    Dim As Single SinAX=Sin(angle.x+da.x)
    Dim As Single SinAY=Sin(angle.y+da.y)
    Dim As Single SinAZ=Sin(angle.z+da.z)
    Dim As Single CosAX=Cos(angle.x+da.x)
    Dim As Single CosAY=Cos(angle.y+da.y)
    Dim As Single CosAZ=Cos(angle.z+da.z)
    '==============these are for direct pixel 
    Dim As Uinteger c
    Dim As Integer pitch
    Dim As Any Ptr row
    Dim As Uinteger Ptr pixel
    '========================================
    
    Dim As Integer ddx,ddy
    
    Imageinfo im,ddx,ddy,,pitch,row
    
    Dim As V3 centre 'the centre of rotation (fulcrum)
    
    centre.x = ddx/2
    centre.y = ddy/2
    centre.z = shift.z
    Dim As V3 result
    
    Dim As Integer dp=1  'size of pixel to fill gaps
    
    For y As Integer=0 To ddy-1
        For x As Integer=0 To ddx-1
            
            '========this bit replaces c=point(x,y,im)=============(point is VERY slow)
            pixel=row+pitch*(y)+(x) Shl 2
            (c)=*pixel  
            '==================================================
            'dx and dy make x and y relative to the image centre
            dx=x-centre.x:dy=y-centre.y
            
            Result.x=((Cosay*Cosaz)*dx+(-Cosax*Sinaz+Sinax*Sinay*Cosaz)*dy+(Sinax*Sinaz+Cosax*Sinay*Cosaz)*dz)+centre.x
            result.y=((Cosay*Sinaz)*dx+(Cosax*Cosaz+Sinax*Sinay*Sinaz)*dy+(-Sinax*Cosaz+Cosax*Sinay*Sinaz)*dz)+centre.y
            result.z=((-Sinay)*dx+(Sinax*Cosay)*dy+(Cosax*Cosay)*dz)+centre.z
            if x=ddx\2 andalso y=ddy\2 then centroid=result 'Bang in the middle
            'this bit is purely to add perspective ================
            w = 1 + (result.z/eyepoint.z)
            result.x = (result.x-eyepoint.x)/w+eyepoint.x
            result.y = (result.y-eyepoint.y)/w+eyepoint.y
            result.z = (result.z-eyepoint.z)/w+eyepoint.z
            Line(result.x+shift.x-dp,result.y+shift.y-dp)-(result.x+shift.x+dp,result.y+shift.y+dp),c,bf
        Next x
    Next y
End Sub

'sort by .z distance
Sub sort(array() As V3,painter() As Integer)
    For p1 As Integer  = 1 To Ubound(array,1) - 1
        For p2 As Integer  = p1 + 1 To Ubound(array,1)  
            If array(p1).z<array(p2).z Then Swap painter(p1),painter(p2):Swap array(p1),array(p2)
        Next p2
    Next p1
End Sub

Function Regulate(Byval MyFps As Integer,Byref fps As Integer) As Integer
    Static As Double timervalue,lastsleeptime,t3,frames
    var t=Timer
    frames+=1
    If (t-t3)>=1 Then t3=t:fps=frames:frames=0
    Var sleeptime=lastsleeptime+((1/myfps)-T+timervalue)*1000
    If sleeptime<1 Then sleeptime=1
    lastsleeptime=sleeptime
    timervalue=T
    Return sleeptime
End Function

'==========================================================================

Screen 19,32,2
dim as any ptr image(1 to 4)
image(1)=imagecreate(300,300)
image(2)=imagecreate(300,300,Rgb(255,255,255))
image(3)=imagecreate(300,300,Rgb(255,255,255))
image(4)=imagecreate(300,300,rgb(100,100,100))
       eyepoint=Type(150,150,600) 'behind image centres

'draw something on each image
For y As Integer=0 To 300
    For x As Integer=0 To 300
        Pset image(1),(x,y),Rgb(x,x Xor y,y)
        If y Mod 100=0 And x Mod 100=0 Then Circle image(2),(x,y),50,Rgb(Rnd*255,Rnd*255,Rnd*255),,,,f
        If y Mod 50=0 And x Mod 50=0 Then Circle image(3),(x,y),10,Rgb(Rnd*255,Rnd*255,Rnd*255),,,,f
         If y Mod 75=0 And x Mod 75=0 Then line image(4),(x-20,y-20)-(x+20,y+20),Rgb(Rnd*255,Rnd*255,Rnd*255),bf
    Next x
Next y

dim as single pi=4*atn(1)
Dim As v3 translate=type(250,150,150)
dim as V3 centroid(1 to 4)
Dim As float angle
Dim As Integer fps
Dim As Integer painter(1 To 4)
For n As Integer=1 To 4:painter(n)=n:Next n
    
    
Screenset 1,0
color ,rgb(0,100,200)
Do
    angle.x+=.05  :if angle.x>=2*pi then angle.x=0
    angle.y+=.025 :if angle.y>=2*pi then angle.y=0
    angle.z+=.015 :if angle.z>=2*pi then angle.z=0
    
    'sort by .z to reset painter and centroids
    sort(centroid(),painter())
    
    Cls
    Draw String(20,20),"Framerate " &fps
    
    for n as integer=1 to 4
        select case as const painter(n)
        case 1:rotateImage(image(1),angle,Translate,centroid(1),type<float>(0,0,0))
        case 2:rotateImage(image(2),angle,Translate,centroid(2),type<float>(pi/2,0,0))
        case 3:rotateImage(image(3),angle,Translate,centroid(3),type<float>(pi,0,0))
        case 4:rotateImage(image(4),angle,Translate,centroid(4),type<float>(3*pi/2,0,0))
        end select
        next n
       
    Flip
      For n As Integer=1 To 4:painter(n)=n:Next n 'reset the painter
    Sleep regulate(20,fps),1
Loop Until Len(Inkey)
Sleep
imagedestroy image(1)
imagedestroy image(2)
imagedestroy image(3)
imagedestroy image(4)

 
補足 に戻る
←リンク元に戻る プログラム開発関連に戻る
ページ歴史:2014-12-16
日本語翻訳:WATANABE Makoto、原文著作者:BasicCoder2 、dodicat

ホームページのトップに戻る

表示-非営利-継承