Template Classes via a macro

[idle]

An example of using a macro to effectively make a class template
this will make a BTree of any arbitrary structured type.
PB 4.51

Thanks for the bug fixes

Code: Select all

;how you can use a macro as a class template
;creates a bTree object class of any structured type

;Template Class of a Btree
;Author Idle
;updated to PB 4.51
EnableExplicit 

Macro Template_class_Btree(T)

Structure Tree#T
   *vt
   item.T;
   key.i
   *left.Tree#T;
   *right.Tree#T;
EndStructure

Declare Free_Tree_#T(*this.Tree#T)
Declare Find_Tree_#T(*this.Tree#T,*item,key)
Declare Insert_Tree_#T(*this.Tree#T,*item,key)
     
Interface Tree_obj_#T
    Insert(*item,key)
    Find(*item,key)
    Free()
EndInterface

Procedure Find_Tree_#T(*this.Tree#T,*item,key.i)
     
    If Not *this
       ProcedureReturn #False
    EndIf
    If *this\key = key
      CopyStructure(*this\item,*item,T) 
      ProcedureReturn #True;
    ElseIf key < *this\key
       ProcedureReturn Find_Tree_#T(*this\left,*item,key);
    Else
       ProcedureReturn Find_Tree_#T(*this\right,*item,key);
    EndIf
           
EndProcedure

Procedure Insert_Tree_#T(*this.Tree#T,*item,key.i)
     
    If Not *this
      *this = AllocateMemory(SizeOf(Tree#T))
      InitializeStructure(*this,T)
      *this\key = key
      CopyStructure(*item,*this\item,T)
     
    Else
      If key <= *this\key
         *this\left = insert_Tree_#T(*this\left,*item,key)
      Else
        *this\right = insert_Tree_#T(*this\right,*item,key)
      EndIf
    EndIf
   
    ProcedureReturn(*this)
   
EndProcedure
   
Procedure Del_Nodes_Tree_#T(*this.Tree#T)
    Static dct
    If *this\left Or *this\right
      If *this\left
        del_nodes_Tree_#T(*this\left)
      EndIf
      If *this\right
        del_nodes_Tree_#T(*this\right)
      EndIf
    EndIf
    If *this\key
      ClearStructure(*this\item,T)
      FreeMemory(*this)
       dct+1
    EndIf
    ProcedureReturn dct   
EndProcedure
     
Procedure Free_Tree_#T(*this.Tree#T)
   Protected ct 
   ct = del_nodes_Tree_#T(*this)
   ClearStructure(*this,Tree#T)
   FreeMemory(*this)
   ProcedureReturn ct
EndProcedure

Procedure New_Tree_#T(*obj.Tree#T)
    *obj = AllocateMemory(SizeOf(Tree#T))
    If *obj
      *obj\vt=?vt_tree#T
    EndIf
    ProcedureReturn *obj
EndProcedure

DataSection: vt_tree#T:
   Data.i @Insert_Tree_#T()
   Data.i @Find_Tree_#T()
   Data.i @Free_Tree_#T()
EndDataSection
   
EndMacro

Structure mixed
  a.i
  str.s 
EndStructure   

;1) call the macro to create the class with your structure
Template_class_BTree(mixed)

 
;2) use the class 
Global mTree.Tree_obj_mixed = new_Tree_mixed(@mTree)
Global Dim aKeys.i(100)
Global tm.mixed
Define a, tstr.s 

For a = 1 To 100
   tstr.s = Str(Random(100)+1)
   aKeys(a) = a
   tm\a = aKeys(a)
   tm\str = tstr
   mTree\insert(@tm,aKeys(a)) ;insert item with a key
Next     
;
For a = 1 To 100
     If mTree\find(@tm,aKeys(a)) ;look up item from key array 
       Debug "item number " + Str(a) + " Found " + tm\str + " " + Str(tm\a)     
     EndIf
Next

Debug mTree\Free()

[Kwai chang caine]

Hello IDLE...

I have not all understand what is a template class
Don't worry it's like usually.

Perhaps there are a link with the template of PB ???

But i have an error line 110

Code: Select all

Template_class_BTree(mixed)

[idle]

No error here with 4.51
What PB version are you using kcc?

A template allows a class to work on many different data types without being rewritten for each one.
So from the users point of view it looks and functions like a PB internal class like a List or Map
It just wasn't as easy to do before because of issues you'd encounter handling strings

[rsts]

On my system the final statement

Code: Select all

debug mTree\Free()

produces a memory error at line 110

cheers
PB 4.51 final
Window 7 x86

[idle]

I'm still on RC2, maybe I was to quick then, will try it with the final.

Installed 4.51 final and still no error or warnings, i'm on XP
also tossed in an InitializeStructure in case that makes any difference edited the first post.

[ts-soft]

Tested with WinXP, x86: no errors

Tested with Win7, x86: error at line 111

PB 4.51 Final

[idle]

what could be the problem there?
back to fixed size strings then I suppose

[idle]

ok so using a fixed size string does it crash on win7 x86

Code: Select all

;how you can use a macro as a class template
;creates a bTree object class of any structured type

;Template Class of a Btree
;Author Idle
;updated to PB 4.51
Macro Template_class_Btree(T)

Structure Tree#T
   *vt
   item.T;
   key.i
   *left.Tree#T;
   *right.Tree#T;
EndStructure

Declare Free_Tree_#T(*this.Tree#T)
Declare Find_Tree_#T(*this.Tree#T,*item,key)
Declare Insert_Tree_#T(*this.Tree#T,*item,key)
     
Interface Tree_obj_#T
    Insert(*item,key)
    Find(*item,key)
    Free()
EndInterface

Procedure Find_Tree_#T(*this.Tree#T,*item,key)
     
    If Not *this
       ProcedureReturn #False
    EndIf
    If *this\key = key
      CopyStructure(*this\item,*item,T) 
      ProcedureReturn #True;
    ElseIf key < *this\key
       ProcedureReturn Find_Tree_#T(*this\left,*item,key);
    Else
       ProcedureReturn Find_Tree_#T(*this\right,*item,key);
    EndIf
           
EndProcedure

Procedure Insert_Tree_#T(*this.Tree#T,*item,key)
     
    If Not *this
      *this = AllocateMemory(SizeOf(Tree#T))
      ;InitializeStructure(*this,T)
      *this\key = key
      CopyStructure(*item,*this\item,T)
     
    Else
      If key <= *this\key
         *this\left = insert_Tree_#T(*this\left,*item,key)
      Else
        *this\right = insert_Tree_#T(*this\right,*item,key)
      EndIf
    EndIf
   
    ProcedureReturn(*this)
   
EndProcedure
   
Procedure Del_Nodes_Tree_#T(*this.Tree#T)
    Static dct
    If *this\key
      ClearStructure(*this,T)
      FreeMemory(*this)
       dct+1
    EndIf
    If *this\left Or *this\right
      If *this\left
        del_nodes_Tree_#T(*this\left)
      EndIf
      If *this\right
        del_nodes_Tree_#T(*this\right)
      EndIf
    EndIf
    ProcedureReturn dct   
EndProcedure
     
Procedure Free_Tree_#T(*this.Tree#T)
   Protected ct   
   ct = del_nodes_Tree_#T(*this)
   ClearStructure(*this,Tree#T)
   FreeMemory(*this)
   ProcedureReturn ct
EndProcedure

Procedure New_Tree_#T(*obj.Tree#T)
    *obj = AllocateMemory(SizeOf(Tree#T))
    If *obj
      *obj\vt=?vt_tree#T
    EndIf
    ProcedureReturn *obj
EndProcedure

DataSection: vt_tree#T:
   Data.i @Insert_Tree_#T()
   Data.i @Find_Tree_#T()
   Data.i @Free_Tree_#T()
EndDataSection

   
EndMacro

Structure mixed
  a.i
  str.s{256}   ;<-fixed size string should not crash 
EndStructure   

;1) call the macro to create the class with your structure
Template_class_BTree(mixed)

 
;2) use the class 
Global mTree.Tree_obj_mixed = new_Tree_mixed(@mTree)
Global Dim aKeys.i(100)
Global tm.mixed

For a = 1 To 100
   tstr.s = Str(Random(100)+1)
   aKeys(a) = a
   tm\a = aKeys(a)
   tm\str = tstr
   mTree\insert(@tm,aKeys(a)) ;insert item with a key
Next     
;
For a = 1 To 100
     If mTree\find(@tm,aKeys(a)) ;look up item from key array 
       Debug "item number " + Str(a) + " Found " + tm\str + " " + Str(tm\a)     
     EndIf
Next

Debug mTree\Free()

[ts-soft]

This works fine

[idle]

yes the fixed string would.
So I wonder what could be the problem on win7, maybe it's a bug with PB
Also in the dynamic sting version
In FreeTree the var ct wasn't declared, though I don't see why that would have made a difference
I only put it there for debugging purposes.

[srod]

It crashes because you have the wrong structure in the ClearStructure() in the Del_Nodes_Tree_#T(*this.Tree#T) function.

Change :

Code: Select all

ClearStructure(*this,T)

to

Code: Select all

ClearStructure(*this,Tree#T)

**EDIT : btw, very difficult to debug when embedded within a macro like this! I removed the macro in order to find the line which was actually causing the problem. This is why I hate the damn things!

[idle]

I'm not sure if that's right either, I'm only trying to clear the items structure which is mixed
if I change it to Tree#T the debug free is only 1 instead of 100

[srod]

Then you need :

Code: Select all

ClearStructure(*this\item,T)

[srod]

The whole Del_Nodes_Tree_#T(*this.Tree#T) procedure looks flawed.

You are possibly freeing the *this structure before then using it again! I think you need to reorder it as follows :

Code: Select all

Procedure Del_Nodes_Tree_#T(*this.Tree#T)
    Static dct
    If *this\left Or *this\right
      If *this\left
        del_nodes_Tree_#T(*this\left)
      EndIf
      If *this\right
        del_nodes_Tree_#T(*this\right)
      EndIf
    EndIf
    If *this\key
      ClearStructure(*this\item,T)
      FreeMemory(*this)
       dct+1
    EndIf
    ProcedureReturn dct   
EndProcedure

[idle]

Thanks
anyone would think I had milk bottles for glasses.

yes maybe your right there too about the recursion