Can I check I understand file put & get correctly?

New to FreeBASIC? Post your questions here.
olympic sleeper
Posts: 41
Joined: Jun 07, 2020 15:47

Can I check I understand file put & get correctly?

Postby olympic sleeper » Jul 29, 2020 14:36

Hi,

Before I delve into a lot of code can I check I've understood file put and get for sequential files correctly?

Its it true that I have an array of a user defined type which itself contains arrays, strings and arrays of strings I can just 'put' the whole thing to a file and then later re-open that file and just 'get' a variable of the same type, without having to worry how big the original type, its strings or its arrays were? This would be a sequential write of the whole array of the type and sequential read of the whole array.

If so Is there anything I need to watch for?

If not would I have to write invividual elements? My reading of the wiki suggests no.

Thanks in advance.
fxm
Posts: 9939
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Can I check I understand file put & get correctly?

Postby fxm » Jul 29, 2020 15:11

As UDT members, this can only work for both fixed-lengths array and fixed-length strings, otherwise (for variable-length arrays/strings) only dangling arrays/strings descriptors would be written to the file and not the data themselves.

Extract of the TYPE documentation page:
Variable-length data
In FreeBASIC, Type data structures must ultimately be fixed-size, such that the compiler knows how much memory to allocate for objects of that Type. Nevertheless, Types may contain variable-length (dynamic) string or array data members. However, the string's/array's data will not be embedded in the Type directly. Instead, the Type will only contain a String/array descriptor structure, which FreeBASIC uses behind the scenes to manage the variable-length string/array data. For sizing the structure of the array descriptor in the Type, a variable-length (dynamic) array data member must be always declared by using Any(S) in place of the array bounds, in order to fix the amount of dimensions based on the number of Anys specified. A variable-length (dynamic) array data member can also be pre-sized in its declaration by using syntax with ReDim.
Variable-length array fields are considered as pseudo-objects when they are declared in a Type, just like variable-length strings (the implicit copy constructor and the implicit let operator themselves support [re]sizing and copying such arrays, or their erasing).

Because of that, saving such a Type into a file will write out the descriptor, not the actual string/array data. In order to embed strings/arrays into Types directly, fixed-length strings/arrays must be used.

Similarly, when maintaining dynamic data manually through the use of pointers within a Type, it does usually not make sense to save the Type to a file, because the address stored in the pointer field will be written to file, not the actual memory it points to. Addresses are meaningful to a specific process only though, and cannot be shared that way.

badidea
Posts: 2149
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Can I check I understand file put & get correctly?

Postby badidea » Jul 29, 2020 16:18

olympic sleeper wrote:If so Is there anything I need to watch for?

Yes, also don't use the (U)Integer data type.
And do use field alignment.

This gives 465 bytes on 32- and 64-bit fbc:

Code: Select all

type udt_5p field = 1
   dim as long x(0 to 4) '5 x 4 = 20 bytes
   dim as long y(0 to 4) '5 x 4 = 20 bytes
end type

type udt_bla field = 1
   dim as string * 64 label '1 + 64 = 65 bytes
   dim as udt_5p list(0 to 9) '10 x 40 = 400 bytes
end type

print sizeof(udt_bla)
fxm
Posts: 9939
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Can I check I understand file put & get correctly?

Postby fxm » Jul 29, 2020 16:38

fxm wrote:As UDT members, this can only work for both fixed-lengths array and fixed-length strings, otherwise (for variable-length arrays/strings) only dangling arrays/strings descriptors would be written to the file and not the data themselves.
.....

On the contrary, the UDT array can be of variable-length (resizable).
badidea
Posts: 2149
Joined: May 24, 2007 22:10
Location: The Netherlands

Re: Can I check I understand file put & get correctly?

Postby badidea » Jul 29, 2020 16:46

A "put" for my example above:

Code: Select all

type udt_5p field = 1
   dim as long x(0 to 4) '5 x 4 = 20 bytes
   dim as long y(0 to 4) '5 x 4 = 20 bytes
end type

type udt_bla field = 1
   dim as string * 64 label '1 + 64 = 65 bytes
   dim as udt_5p list(0 to 9) '10 x 40 = 400 bytes
end type

const as integer NUM_BLA = 3

dim as udt_bla bla(0 to NUM_BLA - 1) '3 x 465 = 1395 bytes

dim as string fileName = "_blabla_.bin"
dim as integer fileNum = freeFile()
if open(fileName for binary as #fileNum) <> 0 then
   print "Error opening: " & fileName
else
   for i as integer = 0 to ubound(bla)
      put #fileNum, , bla(i)
   next
   close #fileNum
   print "Data written to: " & fileName
end if
fxm
Posts: 9939
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Can I check I understand file put & get correctly?

Postby fxm » Jul 29, 2020 16:52

badidea wrote:A "put" for my example above:

Code: Select all

.....
   for i as integer = 0 to ubound(bla)
      put #fileNum, , bla(i)
   next
.....

or simpler:

Code: Select all

.....
   put #fileNum, , bla()
.....
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Can I check I understand file put & get correctly?

Postby dodicat » Jul 29, 2020 17:36

Save and load a udt array.
It is all in the help files.
For no warnings/errors, fixed length strings and arrays.
If you extend object and use OOP in general, then you may be in trouble, but I have not really tested this out yet.
(If you use abstract then you won't be able even to create udt objects in the first place, so you are definitely in trouble.)
You may have to save any child udt's extending the main udt.
I will experiment with saving a game to file -- sometime.


Code: Select all


width 100,500
#include "file.bi"

type udt
    as zstring * 50 num
    as long x,y
    as string * 100 s
    as single a(1 to 8)
    declare sub printout()
end type

sub udt.printout()
    with this
    print .num
    print .x,.y
    print .s
    for m as long=lbound(.a) to ubound(.a)
       print .a(m);
    next m
    print
end with
print
    end sub

sub load(file as string,u() as udt)
   var  f=freefile
   if fileexists(file)=0 then print file;"  not found":return
    Open file For Binary Access Read As #f
    If Lof(f) > 0 Then
      Get #f, ,u()
    End If
    Close #f
    end sub

sub save(file as string,u() as udt)
    var h=freefile
    open file for binary access write as #h
    put #h, ,u()
    close #h
end sub

dim as udt x(1 to 3)

for n as long=lbound(x) to ubound(x)
    with x(n)
    .num= "Element " +str(n)
    .x=n
    .y=n*2
    .s="hi " +string(70,"-") +str(n)
    for m as long=lbound(.a) to ubound(.a)
        .a(m)=rnd
    next m
    end with
next n

print "ORIGINAL"
for n as long=lbound(x) to ubound(x)
    x(n).printout()
next

save("data",x())



var N=filelen("data")\sizeof(udt) 'get the number of elements to load

redim as udt y(1 to N)
load("data",y())
print
print
print "============= FROM FILE ============="
for n as long=1 to ubound(y)
    y(n).printout()
next

sleep
kill "data"

 
Last edited by dodicat on Jul 29, 2020 17:56, edited 1 time in total.
fxm
Posts: 9939
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Can I check I understand file put & get correctly?

Postby fxm » Jul 29, 2020 17:49

Code: Select all

.....
    for m as long=1 to 8 ' and not 10, otherwise out of bounds
        .a(m)=rnd
    next m
.....
dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Can I check I understand file put & get correctly?

Postby dodicat » Jul 29, 2020 17:57

Sorry, fixed that.
grindstone
Posts: 752
Joined: May 05, 2015 5:35
Location: Germany

Re: Can I check I understand file put & get correctly?

Postby grindstone » Jul 30, 2020 7:30

Alternatively, you can write a load/save SUB as member of the TYPE. Here an excerpt of BER approach, a flight operator simulation:

Code: Select all

...

Type tPlane
   callsign As String
   origin As String
   destination As String
   position As tPosition
   target As tPosition
   
   xdisp As Integer
   ydisp As Integer
   tagDispx As Integer
   tagDispy As Integer
   tagDispBasex As Integer = 15 '10
   tagDispBasey As Integer = -29 '-24
   Union
      selbuffer_ As Byte
      selbuffer As tMark
   End Union
   
   altitude As Double 'ft
   targetAltitude As Integer 'ft
   messageAltitude As Integer 'ft
   climbrate As Integer = 30 'ft/min
   descendrate As Integer = 30 'ft/min
   tagAltitude As String
         
   direction As Double 'as angle
   turn As String
   messageTurn As String
         
   speed As Double 'kt
   targetSpeed As Integer 'kt
   messageSpeed As Integer 'kt
   maxSpeed As Integer = 450 'kt  (450kt = 833 km/h) '(500kt = 910 km/h)
   stallSpeed As Integer = 120 'kt (120kt = 222 km/h)
   approachSpeed As Integer = 150 'kt (150kt = 278 km/h)
   cruiseSpeed As Integer = 400 'kt (400kt = 740 km/h)
   acceleration As Integer = 5 'kt/s
   deceleration As Integer = 5 'kt/s
   tagSpeed As String
      
   timerem As Double
   scheduledDepartureTime As Double
   fuel As Double 'as time
   messageLock As Double '= 2
   Union
      planeflags As UShort 'for saving / loading
      planeflag As tPlaneflag
   End Union
   Union
      mark_ As Byte
      mark As tMark
   End Union
   flightstatus As Byte
   runway_ As Byte
   wheelrem As Integer
   listColor As tMMcolors
   comment As String
         
   Static As Integer tagTop
   Static As Integer tagBottom
   Static As Integer tagLeft
   Static As Integer tagRight
   Static As tPlane plane() 'planes array
      
   Declare Static Function create(org As Integer = 0) As boolean
   Declare Sub operate(mode As Integer)
   Declare Function checkApproach(runway As tRunway) As Integer
   Declare Sub savePlane(filenr As Integer)
   Declare Sub loadPlane(filenr As Integer)
   
End Type

'dim static variables
Static As Integer tPlane.tagTop    = -29 '-24
Static As Integer tPlane.tagBottom =  29 '24
Static As Integer tPlane.tagLeft   = -35 '-30
Static As Integer tPlane.tagRight  =  15 '10

ReDim As tPlane tPlane.plane(0)

...


Sub tPlane.savePlane(filenr As Integer)
   
   Print #filenr, "PLANE"
   Print #filenr, callsign
   Print #filenr, destination
   Print #filenr, origin
   Print #filenr, position.x
   Print #filenr, position.y
   Print #filenr, tagDispBasex
   Print #filenr, tagDispBasey
   Print #filenr, target.x
   Print #filenr, target.y
   Print #filenr, selbuffer_
   Print #filenr, altitude
   Print #filenr, targetAltitude
   Print #filenr, messageAltitude
   Print #filenr, direction
   Print #filenr, turn
   Print #filenr, messageTurn
   Print #filenr, speed
   Print #filenr, targetSpeed
   Print #filenr, messageSpeed
   Print #filenr, timerem
   Print #filenr, scheduledDepartureTime
   Print #filenr, fuel
   Print #filenr, planeflags
   Print #filenr, mark_
   Print #filenr, flightstatus
   Print #filenr, runway_
      
End Sub

Sub tPlane.loadPlane(filenr As Integer)
   
   Input #filenr, callsign
   Input #filenr, destination
   Input #filenr, origin
   Input #filenr, position.x
   Input #filenr, position.y
   Input #filenr, tagDispBasex
   Input #filenr, tagDispBasey
   Input #filenr, target.x
   Input #filenr, target.y
   Input #filenr, selbuffer_
   Input #filenr, altitude
   Input #filenr, targetAltitude
   Input #filenr, messageAltitude
   Input #filenr, direction
   Input #filenr, turn
   Input #filenr, messageTurn
   Input #filenr, speed
   Input #filenr, targetSpeed
   Input #filenr, messageSpeed
   Input #filenr, timerem
   Input #filenr, scheduledDepartureTime
   Input #filenr, fuel
   Input #filenr, planeflags
   Input #filenr, mark_
   Input #filenr, flightstatus
   Input #filenr, runway_
   timerem = Timer
   operate(0)
End Sub

...

ff = FreeFile
Open "resume.pln" For Output As #ff
...
For p = 1 To UBound(tPlane.plane)
   tPlane.plane(p).savePlane(ff)
Next
Close ff
   
...

ff = FreeFile
Open "resume.pln" For Input As #ff
...
ReDim tPlane.plane(0)
p = 0
Do Until Eof(ff)
   Input #ff, g
   If g = "PLANE" Then
      p += 1
      tPlane.create(-1)
      tPlane.plane(p).loadPlane(ff)
   EndIf
Loop
Close ff


dodicat
Posts: 6687
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Can I check I understand file put & get correctly?

Postby dodicat » Jul 30, 2020 16:33

Just got my new machine, 64 bit win 10.
I coded saveagame in 32 bit XP.
I coded Loadagame on XP and in my new box, loading the saved file.
(I copied the code over via pen drive)
Saveagame.bas

Code: Select all


#define seed timer
Const xres=1024 'can change within reason
Const yres=768

Type pt
  As Single x,y
  As Long nsides
End Type

Type piece
  As pt vel
  As pt p(1 to 30)
  As Ulong clr
  As Long active
  As zstring * 6 id
  as pt xy
  Declare Sub Construct(As pt,As pt,As Ulong,As pt,As Long,As String ,As Long)
End Type

Type stillpiece Extends piece
End Type

Type killerpiece Extends piece
End Type

Type eaterpiece Extends piece
End Type

Function rotate(pivot As pt,p As pt,a As Single) As pt
  Return  Type<pt>((Cos(a)*(p.x-pivot.x)-Sin(a)*(p.y-pivot.y)) +pivot.x,_
  (Sin(a)*(p.x-pivot.x)+Cos(a)*(p.y-pivot.y)) +pivot.y)
End Function

#define range(f,l) Rnd*((l)-(f))+(f)
#define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)

Sub piece.Construct(xy As pt,wh As pt,c As Ulong,v As pt,a As Long,s As String,sides As Long)
  Dim As Long ctr
  Dim As Single cx,cy
  For z As Single=0 To 360*2 Step 360/sides
    ctr+=1
    If ctr>sides Then Exit For
    p(ctr).x=xy.x+wh.x*Cos(z*.0174533)
    p(ctr).y=xy.y+wh.y*Sin(z*.0174533)
    cx+=p(ctr).x
    cy+=p(ctr).y
  Next z
  cx/=sides:cy/=sides
  Var ang=0.0
  If s="eat" Then ang=Atn(1) Else ang=Rnd
  For n As Long=1 To sides
    p(n)=rotate(Type(cx,cy),p(n),ang)
  Next n
  clr=c
  vel=v
  active=a
  id=s
  p(1).nsides=sides
End Sub

Function inpolygon(p1() As pt,Byval p2 As pt) As Long
  #define Winder(L1,L2,p) ((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y))
  var lim=p1(1).nsides
  Dim As Long index,nextindex,wn,k=lim+1
  For n As Long=1 To lim
    index=n Mod k:nextindex=(n+1) Mod k
    If nextindex=0 Then nextindex=1
    If p1(index).y<=p2.y Then
      If p1(nextindex).y>p2.y Andalso  Winder(p1(index),p1(nextindex),p2)>0 Then wn+=1
    Else
      If p1(nextindex).y<=p2.y Andalso Winder(p1(index),p1(nextindex),p2)<0 Then wn-=1
    End If
  Next n
  Return wn
End Function

Function overlaps(p1() As pt,p2() As pt) As Long
    var lim1=p1(1).nsides,lim2=p2(1).nsides
  For m As Long=1 To lim2
    If inpolygon(p1(),p2(m)) Then Return 1
  Next m
  For m As Long=1 To  lim1
    If inpolygon(p2(),p1(m)) Then Return 1
  Next m
  Return 0
End Function

sub savefile(file as string,u() as piece)
    var h=freefile
    open file for binary access write as #h
    put #h, ,u()
    close #h
end sub

'=======SET UP========
randomize seed
Dim As stillpiece s(1 To 20) 
For n As Long=1 To 20
    dim as ulong clr
  lbl:
  do
    clr=irange(1,15)
    loop until clr<>3 and clr<>14 and clr<>4
 
  Var xx= range(50,xres-50),yy=range(50,yres-50)
  s(n).Construct(Type<pt>(xx,yy),Type<pt>(30,30),clr,Type<pt>(0,0),1,"still",irange(4,8))
  For m As Long=1 To n-1
    If overlaps(s(m).p(),s(n).p()) Then Goto lbl 'keep isolated
  Next m
Next n

Dim As killerpiece k(1 To 3)

For n As Long=1 To 3
  Var xx= range(50,xres-50),yy=range(50,yres-50)
  k(n).Construct(Type<pt>(xx ,yy),Type<pt>(20,20),4,Type<pt>(range(-1,1),range(-1,1)),1,"kill",3)
  'doesn't matter too much if it overlaps a still piece
Next n


Dim As eaterpiece e(1 To 1)
lbl2:
Var xx= range(50,xres-50),yy=range(50,yres-50)
e(1).Construct(Type<pt>(xx ,yy),Type<pt>(35,35),14,Type<pt>(range(-2,2),range(-2,2)),1,"eat",4)
For m As Long=1 To Ubound(k)
  var d=sqr( (e(1).p(1).x-k(m).p(1).x)^2+(e(1).p(1).y-k(m).p(1).y)^2)
  If overlaps(k(m).p(),e(1).p()) or d<200 Then Goto lbl2 'dont want to overlap or be near a killpiece
Next m

redim as piece save()

Dim As Long ctr
For n As Long=Lbound(s) To Ubound(s)'still pieces
  ctr+=1
  Redim Preserve save(1 To ctr)
  save(ctr)=s(n)
Next
For n As Long=Lbound(k) To Ubound(k)'killer pieces
  ctr+=1
  Redim Preserve save(1 To ctr)
  save(ctr)=k(n)
Next
Redim Preserve save(1 To ctr+1)
save(Ubound(save))=e(1)'the eater piece last


save(1).xy.x=xres 'pass the screen resolutions
save(1).xy.y=yres

savefile("gamedata",save())
print "Done"
sleep


 

and loadagame.bas, to run the file.

Code: Select all


#include "fbgfx.bi"
#include "file.bi"
Const jmp=2 'arrow key base stepper
dim shared as long xres
dim shared as long yres

Type pt
  As Single x,y
  As Long nsides
End Type

Type piece
  As pt vel
  As pt p(1 to 30)
  As Ulong clr
  As Long active
  As zstring * 6 id
  as pt xy
  Declare Sub Construct(As pt,As pt,As Ulong,As pt,As Long,As String ,As Long)
  Declare Sub blow(n As Single)
End Type

Function zip() Byref As Single
  Static As Single s
  Return s
End Function

Function rndlim() Byref As Single
  Static As Single s
  Return s
End Function

function key() byref as single
 Static As Single s
  Return s
End Function

Sub fill(p() As pt,c As Ulong,im As Any Ptr=0)
  #define ub Ubound
  Dim As Long Sy=1e6,By=-1e6,i,j,y,k
  Dim As Single a(Ub(p)+1,1),dx,dy
  For i =0 To Ub(p)
    a(i,0)=p(i).x
    a(i,1)=p(i).y
    If Sy>p(i).y Then Sy=p(i).y
    If By<p(i).y Then By=p(i).y
  Next i
  Dim As Single xi(Ub(a,1)),S(Ub(a,1))
  a(Ub(a,1),0) = a(0,0)
  a(Ub(a,1),1) = a(0,1)
  For i=0 To Ub(a,1)-1
    dy=a(i+1,1)-a(i,1)
    dx=a(i+1,0)-a(i,0)
    If dy=0 Then S(i)=1
    If dx=0 Then S(i)=0
    If dy<>0 Andalso dx<>0 Then S(i)=dx/dy
  Next i
  For y=Sy-1 To By+1
    k=0
    For i=0 To Ub(a,1)-1
      If (a(i,1)<=y Andalso a(i+1,1)>y) Orelse _
      (a(i,1)>y Andalso a(i+1,1)<=y) Then
      xi(k)=(a(i,0)+S(i)*(y-a(i,1)))
      k+=1
    End If
  Next i
  For j=0 To k-2
    For i=0 To k-2
      If xi(i)>xi(i+1) Then Swap xi(i),xi(i+1)
    Next i
  Next j
  For i = 0 To k - 2 Step 2
    Line im,(xi(i),y)-(xi(i+1)+1,y),c
  Next i
Next y
End Sub

Function drawpolygon(p() As Pt,clr As Ulong,flag As Long=0) As pt
  Dim As Long sz=p(1).nsides
  Dim As Single cx,cy
  Dim As pt f(sz)
  For n As Long=1 To sz
    f(n-1)=p(n)
    cx+=p(n).x:cy+=p(n).y
  Next
  cx/=sz:cy/=sz
  f(sz)=p(1)
  fill(f(),clr)
  Return Type(cx,cy)
End Function

Function rotate(pivot As pt,p As pt,a As Single) As pt
  Return  Type<pt>((Cos(a)*(p.x-pivot.x)-Sin(a)*(p.y-pivot.y)) +pivot.x,_
  (Sin(a)*(p.x-pivot.x)+Cos(a)*(p.y-pivot.y)) +pivot.y)
End Function

#define range(f,l) Rnd*((l)-(f))+(f)
#define Irange(f,l) Int(Rnd*((l+1)-(f)))+(f)

Sub piece.Construct(xy As pt,wh As pt,c As Ulong,v As pt,a As Long,s As String,sides As Long)
  Dim As Long ctr
  Dim As Single cx,cy
  For z As Single=0 To 360*2 Step 360/sides
    ctr+=1
    If ctr>sides Then Exit For
    p(ctr).x=xy.x+wh.x*Cos(z*.0174533)
    p(ctr).y=xy.y+wh.y*Sin(z*.0174533)
    cx+=p(ctr).x
    cy+=p(ctr).y
  Next z
  cx/=sides:cy/=sides
  Var ang=0.0
  If s="eat" Then ang=Atn(1) Else ang=Rnd
  For n As Long=1 To sides
    p(n)=rotate(Type(cx,cy),p(n),ang)
  Next n
  clr=c
  vel=v
  active=a
  id=s
  p(1).nsides=sides
End Sub

Sub piece.blow(n As Single)
  Dim As Single cx,cy
  var lim=p(1).nsides
  For m As Long=Lbound(p) To lim
    cx+=p(m).x
    cy+=p(m).y
  Next m
 
  cx=cx/lim:cy=cy/lim
  For m As Long=Lbound(p) To lim
    p(m).x=n*(p(m).x-cx)+cx
    p(m).y=n*(p(m).y-cy)+cy
  Next m
End Sub

Type stillpiece Extends piece
  Declare Sub Draw()
End Type

Sub stillpiece.draw()
  drawpolygon(p(),clr)
End Sub

Type killerpiece Extends piece
  Declare  Sub move()
  Declare  Sub Draw()
End Type

Sub killerpiece.move
    var lim=p(1).nsides
 For n As Long=Lbound(p) To lim
  p(n).x+=vel.x*zip
  p(n).y+=vel.y*zip
Next
For n As Long=Lbound(p) To lim
  If p(n).x<1 Or p(n).x>xres-1 Then vel.x=-vel.x:Exit For
  If p(n).y<1 Or p(n).y>yres-1 Then vel.y=-vel.y:Exit For
Next n
End Sub

Sub killerpiece.draw()
  drawpolygon(p(),clr)
End Sub

Type eaterpiece Extends piece
  Declare  Sub move()
  Declare  Sub Draw()
End Type

Sub eaterpiece.move
    var lim=p(1).nsides
    If Multikey(75) Then For n As Long=1 To lim:p(n).x-=jmp+key:Next:key()+=1' r
    If Multikey(77) Then For n As Long=1 To lim:p(n).x+=jmp+key:Next:key()+=1' l
    If Multikey(80) Then For n As Long=1 To lim:p(n).y+=jmp+key:Next:key()+=1 'up
    If Multikey(72) Then For n As Long=1 To lim:p(n).y-=jmp+key:Next:key()+=1 'down
  For n As Long=Lbound(p) To lim'Ubound(p)
  If p(n).x<1 Or p(n).x>xres-1 Then key()=0
  If p(n).y<1 Or p(n).y>yres-1 Then key()=0
  Next n
  static as fb.event e
  screenevent(@e)
  if e.type=fb.EVENT_KEY_RELEASE then key()=jmp
End Sub

Sub eaterpiece.draw()
  Var p=drawpolygon(p(),clr )
  ..draw String(p.x-12,p.y-8),"EAT",0
End Sub

'non methods and overlapping boxes macros
Function inpolygon(p1() As pt,Byval p2 As pt) As Long
  #define Winder(L1,L2,p) ((L1.x-L2.x)*(p.y-L2.y)-(p.x-L2.x)*(L1.y-L2.y))
  var lim=p1(1).nsides
  Dim As Long index,nextindex,wn,k=lim+1
  For n As Long=1 To lim
    index=n Mod k:nextindex=(n+1) Mod k
    If nextindex=0 Then nextindex=1
    If p1(index).y<=p2.y Then
      If p1(nextindex).y>p2.y Andalso  Winder(p1(index),p1(nextindex),p2)>0 Then wn+=1
    Else
      If p1(nextindex).y<=p2.y Andalso Winder(p1(index),p1(nextindex),p2)<0 Then wn-=1
    End If
  Next n
  Return wn
End Function

Function overlaps(p1() As pt,p2() As pt) As Long
    var lim1=p1(1).nsides,lim2=p2(1).nsides
  For m As Long=1 To lim2'Ubound(p2)
    If inpolygon(p1(),p2(m)) Then Return 1
  Next m
  For m As Long=1 To  lim1'Ubound(p1)
    If inpolygon(p2(),p1(m)) Then Return 1
  Next m
  Return 0
End Function

'non member functions
Sub checkimpacts(w() As piece)
  For n1 As Long=1 To Ubound(w)-1
    For n2 As Long=n1+1 To Ubound(w)
      If overlaps(w(n2).p(),w(n1).p()) Then
        If n1=24 And w(n2).id="still" And w(n2).active  Then w(24).blow(1.05):w(n2).active=false
        If n2=24 And w(n1).id="still" And w(n1).active  Then w(24).blow(1.05):w(n1).active=false
        If n1=24 And w(n2).id="kill"  Then w(24).active=false
        If n2=24 And w(n1).id="kill"  Then w(24).active=false
      End If
    Next n2
  Next n1
End Sub

Sub showAllBoxes(w() As piece)
  For n As Long=1 To ubound(w)
     If w(n).id="kill"  Then  Cast(killerpiece Ptr,@w(n))->move
     If w(n).id="eat"   Then  Cast(eaterpiece Ptr,@w(n))->move
   
    If w(n).active Then
      If w(n).id="kill"  Then  Cast(killerpiece Ptr,@w(n))->Draw
      If w(n).id="eat"   Then  Cast(eaterpiece Ptr,@w(n))->Draw
      If w(n).id="still"  Then  Cast(stillpiece Ptr,@w(n))->Draw
    End If
  Next n
End Sub

Function LooksLikeDone(w() As piece) As Long
  Dim As Long ctr
  For n As Long=Lbound(w) To Ubound(w)
    If w(Ubound(w)).active=0 Then
      Screenunlock
      Print "LOSE"
      Return 1
    End If
    If w(n).active=0 Then ctr+=1
  Next n
  If ctr=20 Then
    Screenunlock
    Print "WIN"
    Return 1
  End If
End Function

Sub PopOneBack(w() As piece,s() As piece) 'now and then
  Var z=Irange(1,20)'pop up somewhere else, but clear of others
  Dim As piece eater=w(Ubound(w))
  dim as ulong clr
  If w(z).active=0 And Rnd<rndlim Then
    Dim As stillpiece tmp
    lbl3:
    do
    clr=irange(1,15)
    loop until clr<>3 and clr<>14 and clr<>4
    Var xx= range(50,xres-50),yy=range(50,yres-50)
   
    tmp.Construct(Type<pt>(xx,yy),Type<pt>(30,30),clr,Type<pt>(0,0),1,"still",6)
    For m As Long=1 To Ubound(s)
      If m<>z Then
        If overlaps(s(m).p(),tmp.p()) Then Goto lbl3
      End If
      If overlaps(eater.p(),tmp.p()) Then Goto lbl3
    Next m
    s(z)=tmp
    w(z)=s(z) 'update working array
  End If
End Sub

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

sub load(file as string,u() as piece)
   var  f=freefile
   if fileexists(file)=0 then print file;"  not found":return
    Open file For Binary Access Read As #f
    If Lof(f) > 0 Then
      Get #f, ,u()
    End If
    Close #f
end sub

'====   load the data ==============
var L=filelen("gamedata")\sizeof(piece)
redim as piece w(1 to L)
load("gamedata",w())
dim as piece s(1 to 20)
for n as long=1 to 20
    s(n)=w(n)
    next n
xres=w(1).xy.x 'retrieve the screen resolutions
yres=w(1).xy.y
Screenres xres,yres
Width xres\8,yres\16
Color , 3


'================================================
'start menu
#define inbox(b) mx>b.x And mx<b.x+300 And my>b.y And my<b.y+50
#macro showbox(z,f)
If f =0 Then Line (z.x,z.y)-(z.x+300,z.y+50),0,b Else Line (z.x,z.y)-(z.x+300,z.y+50),4,bf
#endmacro
Dim As pt start(1 To 3)={(200,200),(200,250),(200,300)}

Dim As Long mx,my,btn
Do
  Getmouse mx,my,,btn
  Screenlock
  Cls
  For n As Long=1 To 3
    showbox(start(n),0)
    If n=1 Then Draw String(220,200),"Very easy"
    If n=2 Then Draw String(220,250),"Moderate"
    If n=3 Then Draw String(220,300),"More difficult"
  Next 
  For n As Long=1 To 3
    If inbox(start(n)) Then
      showbox(start(n),1)
      If n=1 Then Draw String(220,200),"Very easy"
      If n=2 Then Draw String(220,250),"Moderate"
      If n=3 Then Draw String(220,300),"More difficult"
      If btn=1 Then
        Select Case n
        Case 1:zip()=1:rndlim()=.001
        Case 2:zip()=2:rndlim()=.01
        Case 3:zip()=4:rndlim()=.05
        End Select
      End If
    End If
  Next n
  Screenunlock
  Sleep 10
Loop Until btn=1
'=================================================
'run game
Dim As Long fps,lastframes,k
Do
  Screenlock
  Cls
  Draw String(10,30),"FPS "&fps
  showAllBoxes(w())
  CheckImpacts(w())
  PopOneBack(w(),s())
  If LooksLikeDone(w()) Then lastframes=1
  if lastframes then k+=1
 
  Screenunlock
   if k>60 then exit do
  Sleep regulate(65,fps)
Loop Until inkey=chr(27)
dim as fb.event ev
 
  do
       screenevent(@ev)
  loop until ev.type=fb.EVENT_KEY_RELEASE

while inkey<>"":wend
Sleep
sleep

 
   

I experimented with extends object and the IS keyword, but the Run-Time Type Info was not passed across in the file and I got a blank screen.
The game is simple, just eat the coloured shapes (arrow keys) without the killer red triangles getting you.
Run saveagame then run loadagame.
Every saveagame run produces a different configuration of shapes.
The file is called "gamedata", it holds a udt array
fxm
Posts: 9939
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Re: Can I check I understand file put & get correctly?

Postby fxm » Jul 30, 2020 18:17

dodicat wrote:I experimented with extends object and the IS keyword, but the Run-Time Type Info was not passed across in the file and I got a blank screen.

Indeed, the first member of such an object is the vptr (pointer to the vtable of its run-time type), but only its value is written in the file.
When restarting the program, there is no reason for the vtable of the type to be create at the same address as during the previous execution.

Return to “Beginners”

Who is online

Users browsing this forum: No registered users and 2 guests