OOP structure style

[Rinzwind]

New edition with interface/structure combination with no problem with composition. Still really wishing for native syntax support to make this less error prone because as of present, to add a method, you have to make changes at 4 different locations in code (interface, objectmethods structure, implementation, constructor)... Code is consistent in structure to make that easier, but still... should not be necessary. All items preceded with an underscore are 'implementation', as in not needed for the programmer that uses the class objects (at least in every day usage scenarios). He's only concerned with the actual Interface.

Code: Select all

;2020 Rinzwind POB Pure Object Based

EnableExplicit

;{-Base Class
;-Base Class
Interface Object
  Free()
EndInterface

Structure _ObjectData
  *vt
EndStructure

Structure _ObjectMethods
  Free.i
EndStructure
Global _ObjectMethods._ObjectMethods

Procedure _ObjectFree(*This._ObjectData)
  ;Protected *methods.Object = *This
  FreeStructure(*This)
EndProcedure

Procedure NewObject(*Data._ObjectData = 0)
  Protected *methods._ObjectMethods
  If *Data = 0: *Data = AllocateStructure(_ObjectData): EndIf
  If *Data\vt = 0: *Data\vt = _ObjectMethods: EndIf 
  *methods = *Data\vt
  With *methods
    If \Free = 0: \Free = @_ObjectFree(): EndIf
  EndWith
;   With *Data
;     \x = x
;   EndWith
  ProcedureReturn *Data
EndProcedure

Macro FreeAndNull(_Data)
  If _Data <> 0: _Data\Free(): _Data = 0: EndIf
EndMacro
;}

;{-Shape Class
;-Shape Class
Interface Shape Extends Object
  MoveBy(dx, dy)
  GetX()
  GetY()
  Area()
  Draw() 
EndInterface

Structure _ShapeData Extends _ObjectData
  x.i
  y.i
EndStructure

Structure _ShapeMethods Extends _ObjectMethods
  MoveBy.i
  GetX.i
  GetY.i
  Area.i ;virtual abstract function (no implementation given)
  Draw.i ;virtual abstract function (no implementation given)
EndStructure
Global _ShapeMethods._ShapeMethods

Procedure _ShapeMoveBy(*This._ShapeData, dx, dy)
  Protected *methods.Shape = *This
  *This\x + dx
  *This\y + dy
EndProcedure

Procedure _ShapeGetX(*This._ShapeData)
  Protected *methods.Shape = *This
   ProcedureReturn *This\x
EndProcedure

Procedure _ShapeGetY(*This._ShapeData)
  Protected *methods.Shape = *This
  ProcedureReturn *This\y
EndProcedure

Procedure NewShape(x, y, *Data._ShapeData = 0)
  Protected *methods._ShapeMethods
  If *Data = 0: *Data = AllocateStructure(_ShapeData): EndIf
  If *Data\vt = 0: *Data\vt = _ShapeMethods: EndIf 
  *methods = *Data\vt
  NewObject(*Data)
  With *methods
    If \GetX = 0: \GetX = @_ShapeGetX(): EndIf
    If \GetY = 0: \GetY = @_ShapeGetY(): EndIf
    If \MoveBy = 0: \MoveBy = @_ShapeMoveBy(): EndIf
  EndWith
  With *Data
    \x = x
    \y = y
  EndWith
  ProcedureReturn *Data
EndProcedure
;}

;{-Rectangle Class
;-Rectangle Class (Inheritance)
Interface Rectangle Extends Shape
 
EndInterface

Structure _RectangleData Extends _ShapeData
  Width.i
  Height.i
EndStructure

Structure _RectangleMethods Extends _ShapeMethods

EndStructure
Global _RectangleMethods._RectangleMethods

Procedure _RectangleArea(*This._RectangleData)
  Protected *methods.Rectangle = *This
  ProcedureReturn *This\Width * *This\Height
EndProcedure

Procedure _RectangleDraw(*This._RectangleData)
  Protected *methods.Rectangle = *This
  With *This
    Debug "Rectangle " + \x + " " + \y + " " + \Width + " " + \Height
  EndWith
EndProcedure

Procedure NewRectangle(x, y, Width, Height, *Data._RectangleData = 0)
  Protected *methods._RectangleMethods
  If *Data = 0: *Data = AllocateStructure(_RectangleData): EndIf
  If *Data\vt = 0: *Data\vt = _RectangleMethods: EndIf 
  *methods = *Data\vt
  NewShape(x, y, *Data)
  With *methods
    If \Area = 0: \Area = @_RectangleArea(): EndIf
    If \Draw = 0: \Draw = @_RectangleDraw(): EndIf
  EndWith
  With *Data
    \Width = Width
    \Height = Height
  EndWith
  ProcedureReturn *Data
EndProcedure
;}

;{-Circle Class
;-Circle Class (Inheritance)
Interface Circle Extends Shape
 
EndInterface

Structure _CircleData Extends _ShapeData
  Radius.i
EndStructure

Structure _CircleMethods Extends _ShapeMethods

EndStructure
Global _CircleMethods._CircleMethods

Procedure _CircleArea(*This._CircleData)
  Protected *methods.Circle = *This
  ProcedureReturn #PI * Sqr(*This\Radius)
EndProcedure

Procedure _CircleDraw(*This._CircleData)
  Protected *methods.Circle = *This
  With *This
    Debug "Circle " + \x + " " + \y + " " + \Radius
  EndWith
EndProcedure

Procedure NewCircle(x, y, Radius, *Data._CircleData = 0)
  Protected *methods._CircleMethods
  If *Data = 0: *Data = AllocateStructure(_CircleData): EndIf
  If *Data\vt = 0: *Data\vt = _CircleMethods: EndIf 
  *methods = *Data\vt
  NewShape(x, y, *Data)
  With *methods
      If \Area = 0: \Area = @_CircleArea(): EndIf
      If \Draw = 0: \Draw = @_CircleDraw(): EndIf
  EndWith
  With *Data
    \Radius = Radius
  EndWith
  ProcedureReturn *Data
EndProcedure
;}

;{-Painting Class
;-Painting Class (Composition)
Interface Painting Extends Object
  Draw()
EndInterface

Structure _PaintingData Extends _ObjectData
  r1.Rectangle
  c1.Circle
EndStructure

Structure _PaintingMethods Extends _ObjectMethods
  Draw.i
EndStructure
Global _PaintingMethods._PaintingMethods

Procedure _PaintingDraw(*This._PaintingData)
  Protected *methods.Painting = *This
  With *This
    \r1\Draw()
    \c1\Draw()
  EndWith
EndProcedure

Procedure _PaintingFree(*This._PaintingData)
  With *this
    \r1\Free()
    \c1\Free()
  EndWith
  _ObjectFree(*This)
EndProcedure

Procedure NewPainting(*Data._PaintingData = 0)
  Protected *methods._PaintingMethods
  If *Data = 0: *Data = AllocateStructure(_PaintingData): EndIf
  If *Data\vt = 0: *Data\vt = _PaintingMethods: EndIf 
  *methods = *Data\vt
  NewObject(*Data)
  With *methods
    If \Draw = 0: \Draw = @_PaintingDraw(): EndIf
    \Free = @_PaintingFree() ;override
  EndWith
  With *Data
    \r1 = NewRectangle(11, 11, 400, 300)
    \c1 = NewCircle(10, 10, 100)
  EndWith
  ProcedureReturn *Data
EndProcedure
;}

Define s1.Shape
s1 = NewShape(11, 12)
Debug s1\GetX()
;s1\Free(): s1 = 0
FreeAndNull(s1)

Define r1.Rectangle
r1 = NewRectangle(21, 22, 300, 200)
Debug r1\Area()
FreeAndNull(r1)

Define p1.Painting
p1 = NewPainting()
p1\Draw()


Procedure MyDraw(*This._PaintingData)
  ;_PaintingDraw(*This)
  Debug "MyDraw"
EndProcedure

;Hot patching of class methods
_PaintingMethods\Draw = @MyDraw()
p1\Draw()

FreeAndNull(p1)

Earlier version pure-structure

Code: Select all

;Based on https://www.state-machine.com/doc/AN_OOP_in_C.pdf
;https://www.purebasic.fr/english/viewtopic.php?p=382866

EnableExplicit

Macro This_()
   CompilerIf #PB_Compiler_Processor = #PB_Processor_x64
   !MOV [p.p_this],Rbp
   CompilerElse
   !MOV [p.p_this],Ebp
   CompilerEndIf
EndMacro


;** Shape Class
Prototype _ShapeCreate(x, y)
Prototype _ShapeMoveBy(dx, dy)
Prototype _ShapeGetX()
Prototype _ShapeGetY()
Prototype _ShapeArea()
Prototype _ShapeDraw()

; Encapsulation: package data and functions together
Structure Shape
  x.i
  y.i
  Create._ShapeCreate
  MoveBy._ShapeMoveBy
  GetX._ShapeGetX
  GetY._ShapeGetY
  Area._ShapeArea ;virtual abstract function (no implmentation given)
  Draw._ShapeDraw ;virtual abstract function (no implmentation given)
EndStructure

Procedure _ShapeMoveBy(dx, dy)
  Protected *this.Shape
  This_()
  *this\x + dx
  *this\y + dy
EndProcedure

Procedure _ShapeGetX()
  Protected *this.Shape
  This_()
   ;!MOV [p.p_this],Rbp
   ProcedureReturn *this\x
EndProcedure

Procedure _ShapeGetY()
  Protected *this.Shape
  This_()
  ProcedureReturn *this\y
EndProcedure

Procedure ShapeCreate(*this.Shape, x, y)
  With *this
    \x = x
    \y = y
    \GetX = @_ShapeGetX()
    \GetY = @_ShapeGetY()
    \MoveBy = @_ShapeMoveBy()
  EndWith
EndProcedure


;** Rectangle Class
; Inheritance: reuse code of base class
Structure Rectangle Extends Shape
  Width.i
  Height.i
EndStructure

Procedure _RectangleArea()
  Protected *this.Rectangle
  This_()
  ProcedureReturn  *this\Width * *this\Height
EndProcedure

Procedure _RectangleDraw()
  Protected *this.Rectangle
  This_()
  With *this
    Debug "Rectangle " + \x + "  " + \y + " " + \Width + " " + \Height
  EndWith
EndProcedure

Procedure RectangleCreate(*this.Rectangle, x, y, width, height)
  ShapeCreate(*this, x, y)
  With *this
    \Width = width
    \Height = height
    \Area = @_RectangleArea()
    \Draw = @_RectangleDraw()
  EndWith
EndProcedure


;** Circle Class
Structure Circle Extends Shape
  Radius.i  
EndStructure

Procedure _CircleArea()
  Protected *this.Circle
  This_()
  ProcedureReturn #PI * Sqr(*this\Radius)
EndProcedure

Procedure _CircleDraw()
  Protected *this.Circle
  This_()
  With *this
    Debug "Circle " + \x + " " + \y + " " + \Radius  
  EndWith
  
EndProcedure

Procedure CircleCreate(*this.Circle, x, y, radius)
  ShapeCreate(*this, x, y)
  With *this
    \Radius = radius
    \Draw = @_CircleDraw()
    \Area = @_CircleArea()
  EndWith
EndProcedure


;** Painting Class
; Composition
Structure Painting Extends Shape
  r1.Rectangle
  c1.Circle
EndStructure

; Goes wrong
Procedure _PaintingDraw()
  Protected *this.Painting
  Protected *r.Rectangle ;debug var
  This_()
  With *this
    *r = *this
    Debug "debug *r: " + *r\x + "  " + *r\y + " " + *r\Width + " " + *r\Height
    Debug "debug this\r1 : " + \r1\x + "  " + \r1\y + " " + \r1\Width + " " + \r1\Height

    \r1\Draw() ;oops, prints *r, not r1
    \c1\Draw() ;...
  EndWith 
EndProcedure

Procedure PaintingCreate(*this.Painting, x, y)
  ShapeCreate(*this, x, y)
  With *this
    RectangleCreate(\r1, x +100, y +200, 80, 40)
    CircleCreate(\c1, x +20, y +20, 5)
    \Draw = @_PaintingDraw()
  EndWith
  
EndProcedure


; Demo

; Polymorphism: call class-implemented virtual function
Procedure DrawShapes(List *Shapes.Shape())
  Debug "DrawShapes"
  ForEach *Shapes()
    *Shapes()\Draw()
  Next
EndProcedure


Define s1.Shape, s2.Shape
ShapeCreate(s1, 0, 1)
ShapeCreate(s2, -1, 2)

Debug "s1: "  + s1\GetX() + " " + s1\GetY()
Debug "s2: "  + s2\GetX() + " " + s2\GetY()
s1\MoveBy(2, -4)
s2\MoveBy(1, -2)
Debug "s1: "  + s1\GetX() + " " + s1\GetY()
Debug "s2: "  + s2\GetX() + " " + s2\GetY()

Define r1.Rectangle, r2.Rectangle

RectangleCreate(r1, 0, 2, 10, 15)
RectangleCreate(r2, -1, 3, 5, 8)
Debug "r1 : " + r1\x + "  " + r1\y + " " + r1\Width + " " + r1\Height
Debug "r2 : " + r2\x + "  " + r2\y + " " + r2\Width + " " + r2\Height
r1\MoveBy(-2, 3)
r2\MoveBy(2, -1)
Debug "r1 : " + r1\x + "  " + r1\y + " " + r1\Width + " " + r1\Height
Debug "r2 : " + r2\x + "  " + r2\y + " " + r2\Width + " " + r2\Height

Debug "r1 area: " + r1\Area()
Debug "r2 area: " + r2\Area()

r1\Draw()
r2\Draw()

Define *s1.Shape
*s1 = r1
*s1\Draw()

Define c1.Circle
CircleCreate(c1, 4, 4, 4)

NewList *Shapes.Shape()
AddElement(*Shapes())
*Shapes() = r1
AddElement(*Shapes())
*Shapes() = r2
AddElement(*Shapes())
*Shapes() = c1
DrawShapes(*Shapes())

; Does not work correctly :(
Define p1.Painting
PaintingCreate(p1, 1, 1)
Debug "expected: p1\r1 : " + p1\r1\x + "  " + p1\r1\y + " " + p1\r1\Width + " " + p1\r1\Height
p1\Draw()

[Mijikai]

Any reason why you prefere prototypes over a interface?

[Rinzwind]

More elegant/KISS (imho ofcourse.. different opinions)

You're free to post an interface version of above functionality here.

[Mijikai]

I was just curious as prototypes can be placed anywhere a vtable not.

[Denis]

Hi Rinzwind,

interesting way...

[skywalk]

Yes, I use this simple approach for basic classes. No interface or vtable.
Key is the macro to get the caller.

[Olli]

Hello Rinzwind,

I can see a critical difficulty : no complete polymorphism.

Macros are strongly not recursive. What it prevents us to force the PB compiler to do types analysis.

It should be possible to search in the macros system of FASM to separate depending of string or non-string behaviors.

But, it stays two problems : the float or non-float sort, first, and, secondly, the immediate or indirect data access. The first problem hides too, a bit-range problem. And the second one hides too, an existing constant problem.

To conclude, the best solving problem is make (in PureBasic), a tool. The native tool system is a little bit hard to explain to install, but easy to handle and to transform. The simplest way is recreate a compiler session, with the behaviours you want and code exactly.
This limits you to use this system only for you and the owners of a PureBasic licence.

[Rinzwind]

Sorry, I cant follow, only guess. Maybe add some pseudo code to demonstrate. Nested structures can pose a problem with that assembler line I guess.

Of course unless PB gets some basic optional object syntax things stay workarounds.

Dynamic dispatch is also hard to implement without using new data types etc. And the lack of direct array and structure initialization makes things more unwieldy (Feature Request).

[Olli]

No problem. Do you have the link to the last feature request you described ?

One of the characteristics of the polymophism is call a procedure (method or not) by several coded ways.

Example :

Code: Select all

Display(alpha)

If alpha is an integer, we can create this

Code: Select all

Procedure Display1i(I.I)
MessageRequester("Integer equ to", Str(I) )
EndProcedure

If alpha is a string, we can create this

Code: Select all

Procedure Display1s(S.S)
MessageRequester("String equ to", S)
EndProcedure

The problem is that it does not exist a feature to add the right suffix : 1i for one integer, and 1s for one string.

The rest I said in my long text ( ! ) belongs to the several reasons, we cannot add this feature.

And finally, in my humble opinion, if you want quickly any good results, and bypass what it misses technically, the pragmatic problem solving is you treat directly the source code through #PB_Compiler_File from text file to text file to convert OOP to procedural. The IDE editor allows us to ease the new tool use, for this type of change.

[Mijikai]

No problem. Do you have the link to the last feature request you described ?

One of the characteristics of the polymophism is call a procedure (method or not) by several coded ways.

Example :

Code: Select all

Display(alpha)

If alpha is an integer, we can create this

Code: Select all

Procedure Display1i(I.I)
MessageRequester("Integer equ to", Str(I) )
EndProcedure

If alpha is a string, we can create this

Code: Select all

Procedure Display1s(S.S)
MessageRequester("String equ to", S)
EndProcedure

U still need two different functionalities in one proceure!
One to handle strings and one to handle integers...

Anyway as functions under the hood never care about parameter types
u can always do ur own thing and 'assign' types manually.

[skywalk]

I find OOP macro's and preprocessors far too cumbersome and inelegant.
Better to code up your overloaded functions as needed until/if ever/ PB adds that feature...
I have maybe a dozen of these duplicated functions to handle I-D-S types.
Once written, no more fuss and portable code I can understand 1 year later.

[Rinzwind]

As I was afraid of, composition causes troubles with that one ASM line (see last demo in updated first post). Any solutions?

[Olli]

Technically, you deal any attributes over and under the methods addresses. It is unable to get simply.

I gave a link to the tool menu. It is far the better way

[Mijikai]

Any solutions?

Use Interfaces they are designed for this.

[Rinzwind]

Interfaces were added to pb to interface with external library objects like COM, not to create objects in pb. Its missing some critical pieces for that and because of that needs a lot of boiler plate code (heck even a structure itself for state) and macros to lessen that copy pasting editing pain. Macros make it ugly and debugging becomes harder. Of course you can create code generators (which is what is meant with “tool menu” I guess?) but thats not a solution, just a hacky workaround.

Well, like I said it all are workarounds until the day pb gets some syntax support for stuff like this. No way to have more complex asm to fix this for now? Back to supportive procedures that accept the structure as first argument then, but that doesnt nicely group possible functions together with autocomplete.