Another update from ingydotnet^djgoku

Task/Polymorphism/ALGOL-68/polymorphism.alg

@@ -0,0 +1,95 @@
+# Algol 68 provides for polymorphic operators but not procedures             #
+
+# define the CIRCLE and POINT modes                                          #
+MODE POINT  = STRUCT( REAL x, y    );
+MODE CIRCLE = STRUCT( REAL x, y, r );
+
+
+# PRINT operator                                                             #
+OP PRINT = ( POINT  p )VOID: print( ( "Point(", x OF p, ",", y OF p, ")" ) );
+OP PRINT = ( CIRCLE c )VOID: print( ( "Circle(", r OF c, " @ ", x OF c, ",", y OF c, ")" ) );
+
+# getters                                                                    #
+OP XCOORD = ( POINT p )REAL: x OF p;
+OP YCOORD = ( POINT p )REAL: y OF p;
+
+OP XCOORD = ( CIRCLE c )REAL: x OF c;
+OP YCOORD = ( CIRCLE c )REAL: y OF c;
+OP RADIUS = ( CIRCLE c )REAL: r OF c;
+
+# setters                                                                    #
+# the setters are dyadic operators so need a priority - we make them lowest  #
+# priority, like PLUSAB etc.                                                 #
+# They could have the same names as the getters but this seems clearer?      #
+PRIO SETXCOORD = 1
+   , SETYCOORD = 1
+   , SETRADIUS = 1
+   ;
+# the setters return the POINT/CIRCLE being modified so we can write e.g.    #
+# "PRINT ( p SETXCOORD 3 )"                                                  #
+OP   SETXCOORD = ( REF POINT  p, REAL x )REF POINT:  ( x OF p := x; p );
+OP   SETYCOORD = ( REF POINT  p, REAL y )REF POINT:  ( y OF p := y; p );
+
+OP   SETXCOORD = ( REF CIRCLE c, REAL x )REF CIRCLE: ( x OF c := x; c );
+OP   SETYCOORD = ( REF CIRCLE c, REAL y )REF CIRCLE: ( y OF c := y; c );
+OP   SETRADIUS = ( REF CIRCLE c, REAL r )REF CIRCLE: ( r OF c := r; c );
+
+# operands of an operator are not automatically coerced from INT to REAL so  #
+# we also need these operators                                               #
+OP   SETXCOORD = ( REF POINT  p, INT  x )REF POINT:  ( x OF p := x; p );
+OP   SETYCOORD = ( REF POINT  p, INT  y )REF POINT:  ( y OF p := y; p );
+
+OP   SETXCOORD = ( REF CIRCLE c, INT  x )REF CIRCLE: ( x OF c := x; c );
+OP   SETYCOORD = ( REF CIRCLE c, INT  y )REF CIRCLE: ( y OF c := y; c );
+OP   SETRADIUS = ( REF CIRCLE c, INT  r )REF CIRCLE: ( r OF c := r; c );
+
+# copy constructors                                                          #
+# A copy constructor is not needed as assignment will generate a copy        #
+# e.g.: "POINT pa, pb; pa := ...; pb := pa; ..." will make pb a copy of pa   #
+
+# assignment                                                                 #
+# It is not possible to redefine the assignment "operator" in Algol 68 but   #
+# assignment is automatically provided so no code need be written for e.g.   #
+# "CIRCLE c1 := ...."                                                        #
+
+# destructors                                                                #
+# Algol 68 does not include destructors. A particular postlude could,        #
+# in theory be provided if specific cleanup was requried, but this would     #
+# occur at the end of the program, not at the end of the lifetime of the     #
+# object.                                                                    #
+
+# default constructor                                                        #
+# Algol 68 automatically provides generators HEAP and LOC, which will        #
+# create new objects of the specified MODE, e.g. HEAP CIRCLE will create a   #
+# new CIRCLE. HEAP allocates apace on the heap, LOC allocates in on the      #
+# stack (so the new item disappears when the enclosing block procedure or    #
+# operator finishes)                                                         #
+
+# a suitable "display" (value list enclosed in "(" and ")") can be cast to   #
+# the relevent MODE, allowing us to write e.g.:                              #
+# "POINT( 3.1, 2.2 )" where we need a new item.                              #
+
+# "constructors" with other than all the fields in the correct order could   #
+# be provided as procedures but each would need a distinct name              #
+# e.g.                                                                       #
+PROC new circle at the origin = ( REAL r )REF CIRCLE:
+      ( ( HEAP CIRCLE SETRADIUS r ) SETXCOORD 0 ) SETYCOORD 0;
+PROC new point at the origin = REF POINT:
+      ( HEAP POINT SETXCOORD 0 ) SETYCOORD 0;
+
+
+# examples of use                                                            #
+
+BEGIN
+
+    CIRCLE c1 := CIRCLE( 1.1, 2.4, 4.1 );
+    POINT  p1 := new point at the origin;
+
+    PRINT c1; newline( stand out );
+
+    # move c1 so it is centred on p1                                         #
+    ( c1 SETXCOORD XCOORD p1 ) SETYCOORD YCOORD p1;
+
+    PRINT c1; newline( stand out )
+
+END

Task/Polymorphism/Forth/polymorphism-2.fth

@@ -0,0 +1,50 @@
+include FMS-SI.f
+
+:class point
+  ivar x  \ instance variable
+  ivar y
+  :m print x ? y ? ;m  \ define print method
+  :m get ( -- x y ) x @ y @ ;m
+  :m put ( x y -- ) y ! x ! ;m
+  :m copy ( -- point-obj2 )
+     self get heap> point dup >r put r> ;m
+;class
+
+point p1  \ instantiate object p1
+23 5 p1 put
+p1 print
+p1 copy value p2 \ copy constructor
+p2 print
+p2 <free  \ destructor
+
+.. p1.x ?   \ print just x
+.. p1.y ?   \ print just y
+8 .. p1.x ! \ change just x
+9 .. p1.y ! \ change just y
+
+
+:class circle
+  point center  \ re-use point class for instance variable
+  ivar radius
+  :m print center print radius ? ;m  \ send print message to instance variable
+  :m get ( -- x y r )
+    center get radius @ ;m
+  :m put ( x y r -- )
+    radius ! center put ;m
+  :m copy ( -- circle-obj2 )
+     self get heap> circle dup >r put r> ;m
+;class
+
+circle c1
+4 5 2 c1 put
+c1 print
+c1 copy value c2
+c2 print
+c2 <free
+
+.. c1.center print \ print just center
+.. c1.center.x ?   \ print just x
+.. c1.center.y ?   \ print just y
+.. c1.radius ?     \ print just radius
+p1 get .. c1.center put \ change just center using a point
+100 .. c1.radius ! \ change just radius

Task/Polymorphism/Fortran/polymorphism.f

@@ -9,6 +9,9 @@ module geom
      procedure, public :: set_x
      procedure, public :: set_y
      procedure, public :: print => print_point
+     procedure, pass :: copy_point
+     !overloaded assignment operator
+     generic, public :: assignment(=) => copy_point
   end type point
 
   type, extends(point) :: circle
@@ -17,8 +20,20 @@ module geom
      procedure, public :: get_r
      procedure, public :: set_r
      procedure, public :: print => print_circle
+     procedure, pass :: copy_circle
+     !overloaded assignment operator
+     generic, public :: assignment(=) => copy_circle
   end type circle
 
+  ! constructor interface
+  interface circle
+  module procedure circle_constructor
+  end interface circle
+  ! constructor interface
+  interface point
+  module procedure point_constructor
+  end interface point
+
 contains
 
   real(8) function get_x(this)
@@ -64,18 +79,51 @@ contains
     write(*,'(3(a,f0.4),a)') 'Circle(',this%x,', ',this%y,'; ',this%r,')'
   end subroutine print_circle
 
+  subroutine copy_point(this, rhs)
+      class(point), intent(inout) :: this
+      type(point), intent(in) :: rhs
+      this%x = rhs%x
+      this%y = rhs%y
+  end subroutine copy_point
+
+  subroutine copy_circle(this, rhs)
+      class(circle), intent(inout) :: this
+      type(circle), intent(in) :: rhs
+      this%x = rhs%x
+      this%y = rhs%y
+      this%r = rhs%r
+  end subroutine copy_circle
+
+! non-default constructor to init private components
+  type(point) function point_constructor(x,y)
+  real(8), intent(in) :: x,y
+  point_constructor%x = x
+  point_constructor%y = y
+  end function point_constructor
+! non-default constructor to init private components
+  type(circle) function circle_constructor(x,y,r)
+  real(8), intent(in) :: x,y,r
+  circle_constructor%x = x
+  circle_constructor%y = y
+  circle_constructor%r = r
+  end function circle_constructor
+
 end module geom
 
 program inh
   use geom
 
-  type(point)  :: p
-  type(circle) :: c
+  type(point)  :: p, p_copy
+  type(circle) :: c, c_copy
 
   p = point(2.0d0, 3.0d0)
   call p%print
+  p_copy = p
+  call p_copy%print
 
   c = circle(3.0d0, 4.0d0, 5.0d0)
   call c%print
+  c_copy = c
+  call c_copy%print
 
 end program inh

Task/Polymorphism/Self/polymorphism.self

@@ -0,0 +1,21 @@
+traits point = (|
+  parent* = traits clonable.
+  printString = ('Point(', x asString, ':', y asString, ')').
+  |)
+
+point = (|
+  parent* = traits point.
+  x <- 0.
+  y <- 0
+  |)
+
+traits circle = (|
+  parent* = traits clonable.
+  printString = ('Circle(', center asString, ',', r asString, ')').
+  |)
+
+circle = (|
+  parent* = traits circle.
+  center <- point copy.
+  r <- 0
+  |)