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)
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()