{ |one, step, back| }

The Shape Example in Foxpro

Contributed by Scott Anderson

Polymorphic XBase! Well, FoxPro 2.5a to be precise...

The class defs, method vtable, object defs, and object slot values are implemented in tables.

FoxPro uses the & character to do macro substitution. The procedure call syntax is a little wierd:

  do procname with arg1, arg2, ...

It's different from the function call syntax:

  x = funcname(arg1, arg2, ...)

I used macro substitution to accomplish the dynamic dispatch:

  do &methodname with &args

Other notes:

Code for Foxpro

File: shapes.prg

&& FoxPro 2.x shapes example
&& November 9, 1999 - Scott Anderson

&& set up the tables
do mktables

&& set up the class definitions
do defclasses

&& put the shapes in an array
dimension aShapes[2]

aShapes[1] = createobj('rect1', 'rectangle', '10, 20, 5, 6')
aShapes[2] = createobj('circ1', 'circle', '15, 25, 8')

&& loop through and display the magic of polymorphism in FoxPro
for i = 1 to 2
	do callmethod with aShapes[i], 'draw', ''
	do callmethod with aShapes[i], 'r-move-to', '100, 100'
	do callmethod with aShapes[i], 'draw', ''
endfor

&& call a rectangle-specific function
r = createobj('rect2', 'rectangle', '0, 0, 15, 15')

do callmethod with r, 'set-width', '30'

do callmethod with r, 'draw', ''

&& exit the program
cancel


&&&&&&&&&&&&&&&&&&&&&&&&&&&
&& define the class methods

&& create a shape
procedure c_shape
parameter obj, x, y
	&& set the origin
	do setslot with obj, 'x', str(x)
	do setslot with obj, 'y', str(y)
return

&& move a shape to an absolute position
procedure c_moveto
parameter obj, newx, newy
	do setslot with obj, 'x', newx
	do setslot with obj, 'y', newy
return

&& move a shape relative to its origin
procedure s_rmoveto
parameter obj, delx, dely
	&& note that the slot values are stored as strings
	x = val(getslot(obj, 'x'))
	y = val(getslot(obj, 'y'))
	
	do setslot with obj, 'x', str(x + delx)
	do setslot with obj, 'y', str(y + dely)
return

&& create a rectangle
procedure c_rect
parameter obj, x, y, w, h
	&& call the shape constructor first
	do c_shape with obj, x, y

	&& set the width and height
	do setslot with obj, 'width', str(w)
	do setslot with obj, 'height', str(h)
return

&& set a rectangle width
procedure s_recw
parameter obj, neww
	do setslot with obj, 'width', str(neww)
return

&& set a rectangle height
procedure s_rech
parameter obj, newh
	do setslot with obj, 'height', str(newh)
return

&& draw a rectangle
procedure o_recdraw
parameter obj

	x = alltrim(getslot(obj, 'x'))
	y = alltrim(getslot(obj, 'y'))
	w = alltrim(getslot(obj, 'width'))
	h = alltrim(getslot(obj, 'height'))

	? 'Drawing a rectangle at: (' + x + ', ' + y + '), width: ' + w + ',
height: ' + h
return

&& create a circle
procedure c_circle
parameter obj, x, y, r
	&& call the shape constructor first
	do c_shape with obj, x, y

	&& set the radius
	do setslot with obj, 'radius', str(r)
return

&& set a circle radius
procedure s_circr
parameter obj, newr
	do setslot with obj, 'radius', newr
return

&& draw a circle
procedure o_circdraw
parameter obj
	x = alltrim(getslot(obj, 'x'))
	y = alltrim(getslot(obj, 'y'))
	r = alltrim(getslot(obj, 'radius'))

	? 'Drawing a circle at: (' + x + ', ' + y + '), radius: ' + r
return


&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
&& everything below implements the class framework

&& set a slot on an instance
procedure setslot
parameter obj, slotname, newval
	select objslots
	replace slotval with m.newval all for name = m.obj .and. slot =
m.slotname
return

&& get a slot value from an instance
function getslot
parameter obj, slotname
	select slotval from objslots into array aSlot where name = m.obj .and.
slot = m.slotname
return aSlot[1]


&& get a method name by class
function getcmethod
parameter cname, methname

	&& look the class and method up in the vtable
	select clsmeth
	locate for name = cname .and. method = methname

	if found() then
		mname = vlink
	else
		? 'Unknown class: ' + cname
		cancel
	endif

return mname

&& get a method name by object
function getomethod
parameter oname, methname

	&& first get the class of the object
	select objects
	locate for name = oname

	if found() then
		cname = class
	else
		? 'Unknown object: ' + oname
		cancel
	endif

	&& now get the method from the class vtable
	mname = getcmethod(class, methname)

return mname

&& call a method on a class
procedure callmethod
parameter oname, methname, args
	&& get the method name
	mname = getomethod(oname, methname)

	&& if there are args to the method, use them, otherwise not
	&& the & is a macro substitution, allowing dynamic function calls
	if len(args) > 0 then
		do &mname with oname, &args
	else
		do &mname with oname
	endif
return


&& create a new instance of a class
function createobj
parameter oname, cname, args

	&& create the object
	insert into objects (name, class) values (oname, cname)

	&& set up the default values first
	select m.oname, slot, defval from clsslot into array aDefault where
name = cname
	insert into objslots from array aDefault

	&& get the creation method for the class
	&& don't use callmethod since it requires an instance
	mname = getcmethod(cname, 'create')
	
	&& if there are args to the create method, use them, otherwise not
	&& the & is a macro substitution, allowing dynamic function calls
	if len(args) > 0 then
		do &mname with oname, &args
	else
		do &mname with oname
	endif

return oname

&& add a slot definition to a class
procedure addslot
parameter cname, slotname, dval
	insert into clsslot (name, slot, defval) values (cname, slotname, dval)
return

&& add a method to a class in the vtable
procedure addmethod
parameter cname, methname, vlinkn
	insert into clsmeth (name, method, vlink) values (cname, methname,
vlinkn)
return

&& create a new class
procedure newclass
parameter cname, inhname

	&& make sure we don't already have one
	select classes
	locate for name = cname

	if found() then
		? 'Class ' + cname + 'is already defined.'
		cancel
	endif

	&& define the class
	insert into classes (name, inherits) values (cname, inhname)
	
	&& if it inherits another class, copy the slot and method defs
	if len(inhname) > 0 then
		select m.cname, method, vlink from clsmeth into array aInherit where
name = inhname .and. !(method = 'create')
		insert into clsmeth from array aInherit

		select m.cname, slot, defval from clsslot into array aInherit where
name = inhname
		insert into clsslot from array aInherit
	endif

return

&& make sure we have our tables set
procedure mktables
	set safety off

	close all

	if file('classes.dbf')
		delete file 'classes.dbf'
	endif

	create table classes (name c(20), inherits c(10))
	use classes in 1 exclusive

	
	if file('clsmeth.dbf')
		delete file 'clsmeth.dbf'
	endif

	create table clsmeth (name c(20), method c(10), vlink c(10))
	use clsmeth in 2 exclusive
	
	if file('clsslot.dbf')
		delete file 'clsslot.dbf'
	endif

	create table clsslot (name c(20), slot c(10), defval c(20))
	use clsslot in 3 exclusive
	
	if file('objects.dbf')
		delete file 'objects.dbf'
	endif

	create table objects (name c(20), class c(20))
	use objects in 4 exclusive
	
	if file('objslots.dbf')
		delete file 'objslots.dbf'
	endif

	create table objslots (name c(20), slot c(10), slotval c(20))
	use objslots in 5 exclusive
return

procedure defclasses
	&& define the base shape class
	do newclass with 'shape', ''
	
	&& give it some slots with defaults
	do addslot with 'shape', 'x', '0'
	do addslot with 'shape', 'y', '0'
	
	&& notes on my naming convention:
	&& 	c_ is a create method
	&& 	s_ is a setter-type method
	&& 	o_ is an output method

	&& give it a create method and some move methods
	do addmethod with 'shape', 'create', 'c_shape'
	do addmethod with 'shape', 'move-to', 's_moveto'
	do addmethod with 'shape', 'r-move-to', 's_rmoveto'

	&& define the rectangle class as a subclass of shape	
	do newclass with 'rectangle', 'shape'
	do addslot with 'rectangle', 'width', '0'
	do addslot with 'rectangle', 'height', '0'
	do addmethod with 'rectangle', 'create', 'c_rect'
	do addmethod with 'rectangle', 'set-width', 's_recw'
	do addmethod with 'rectangle', 'set-height', 's_rech'
	do addmethod with 'rectangle', 'draw', 'o_recdraw'
	
	&& define the circle class as a subclass of shape	
	do newclass with 'circle', 'shape'
	do addslot with 'circle', 'radius', '0'
	do addmethod with 'circle', 'create', 'c_circle'
	do addmethod with 'circle', 'set-radius', 's_circr'
	do addmethod with 'circle', 'draw', 'o_circdraw'
return