\ Preprocessor FOOS demo - Copyright 2013 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License

\ Create two classes Point(x,y) and Circle(x,y,r) with a polymorphic function
\ print, accessors for (x,y,r), copy constructor, assignment and destructor
\ and every possible default constructors

include lib/memcell.4th
include 4pp/lib/foos.4pp
include 4pp/lib/ansforth.4pp

:: Point                               ( xn n a--)
   class
     field:  x                         \ x coordinate
     field:  y                         \ y coordinate
     virtual: print                    \ print routine
     virtual: setx                     \ set x coordinate
     virtual: sety                     \ set y coordinate
     virtual: getx                     \ get x coordinate
     virtual: gety                     \ get y coordinate
   end-class {
                                       \ bind the methods immediately
     :virtual setx { this -> x ! } ;method
     :virtual sety { this -> y ! } ;method
     :virtual getx { this -> x @ } ;method
     :virtual gety { this -> y @ } ;method
                                       \ because we'll use them immediately
     :virtual print {                  \ e.g. in this print routine
       ." Point(" this => getx 0 .r ." ," this => gety 0 .r ." )" cr
     } ;method                         \ and this initialization
                                       \ object or argument count
     dup type@ this type@ =            \ if it is an object, a point
     if                                \ get the coordinates and set them
       dup => getx this => setx
           => gety this => sety
     else                              \ otherwise initialize it
       0 dup this => setx this => sety
       case                            \ and check the argument count
         1 of this => setx endof       \ one argument : x only
         2 of this => setx             \ two arguments: x and y
              this => sety endof
       endcase
     then

     private{ x y }                    \ make x and y private
   }
;                                      \ NOTE: "Circle" has a dirty construct
                                       \ you cannot determine the parent type
:: Circle                              ( xn n a --)
   over >r                             ( arg-count object-addr)
   extends Point                       \ save the argument count!!
     field:  r                         \ radius
     virtual: getr                     \ get radius
     virtual: setr                     \ set radius
   end-extends r> swap {               \ retrieve count
                                       \ bind the methods immediately
     :virtual setr { this -> r ! } ;method
     :virtual getr { this -> r @ } ;method
                                       \ because we'll use them immediately
     :virtual print {                  \ e.g. in this print routine
       ." Circle(" this => getx 0 .r ." ,"
                   this => gety 0 .r ." ,"
                   this => getr 0 .r ." )" cr
     } ;method                         \ and this initialization
                                       \ object or argument count
     dup type@ this type@ =            \ if it is an object, a circle
     if                                \ get the coordinates and set them
       dup => getx this => setx
       dup => gety this => sety
           => getr this => setr
     else                              \ otherwise initialize it
       0 this => setr
       case                            \ and check the argument count
         3 of this => setr             \ three arguments: x, y and r
              this => sety             \ note the rest is already set
              this => setx endof       \ by "Point" and r was left on
       endcase                         \ the stack!
     then

     private{ r }
   }
;

0 instance Point Point1
Point1 => print
45 23 2 instance Point Point2
Point2 => print
Point2 instance Point Point3
Point3 => print
78 1 instance Point Point4
Point4 => print
10 45 23 3 instance Circle Circle1
Circle1 => print
Point2 instance Circle Circle2
Circle2 => print
Circle1 instance Circle Circle3
Circle3 => print

depth .