Why modify mold? Just use delegation inheritance.
REBOL [
Title: "Delegation Object inheritence"
Comment: "Much the way CLOS works"
Author: "Jeff Kreis"
]
make-child: func [
"Make a delegating child"
definition [block!] "Child object definition"
'parnt "Word that refers to parent object"
/local par chl pass parent chld child
parental-responsibilities
][
;-Make sure of parent
if any [not parent: get parnt not object? parent][
make error! reform [
"This is a poor excuse for a parent:" parent
]
]
;-determine what the parent can do
; (what functions)
parental-responsibilities: copy []
par: next first parent
foreach word par [
if any-function? get in parent word [
append parental-responsibilities word
]
]
;-determine what the child can do
chl: copy []
chld: make object! definition
foreach word next first chld [
if any-function? get in chld word [
append chl word
]
]
;- build the child containing
; linkage to unique parent functions
child: copy [parent: none]
foreach word exclude parental-responsibilities chl [
;- build the parent calling mechanism
repend child [to-set-word word 'func args: get-args get in parent word]
append/only child compose [return (to-path reduce ['parent word]) (args)]
]
;- rewrite overloaded child functions
; to pass up to parent on failure
foreach word intersect parental-responsibilities chl [
append child reduce [
to-set-word word 'function args: get-args fun: get in chld word [child
result]
;- first class function value
compose/deep [
;- args ;- body
child: func [(first :fun)] [(second :fun)]
either result: child (args) [result][
(to-path reduce ['parent word]) (args)
]
]
]
]
; remake the child with new definition
;- add reference to parent and
child: make chld child
child/parent: get parnt
child
]
get-args: func [
"Get function args up to first refinement"
args [any-function!] /local nargs
][
args: first :args
nargs: copy []
forall args [
either word? args/1 [
append nargs args/1
][if refinement? args/1 [return nargs]]
] nargs
]
;-- Kermit the frog example
frog: make object! [
color: does [0.255.0]
sound: does ["ribbit ribbit"]
skin: does ["slippery"]
species: does ["amphibian"]
food: [
fly yummy
water-bug mmmmm
]
eat: func [thing][
select food thing
]
animals: [
flys loves
goats ignores
bats hates
]
likes: func [animal][
select animals animal
]
]
kermit: make-child [
;- overload what we like
color: does [0.188.12]
sounds: [
"Welcome to the show!"
"It ain't easy being green"
["Today's number is" random 12]
]
sound: func [/what] [
either block? what: pick sounds random 6 [
reform what
][what]
]
skin: does ["foam"]
animals: [
pig loves
puppets loves
humans tolerates
]
likes: func [animal][
select animals animal
]
food: [
hamburger gulp
]
eat: func [thing][
select food thing
]
] frog
;-- Add some more food to parent
append frog/food [grass yuck]
print ["Does kermit eat grass?" kermit/eat 'grass]
;- save kermit the normal way
save %kermit-frog.r kermit
;- see what kermit can do
; then reload kermit and
; see if kermit is still
; the same frog
did: no
loop 2 [
foreach [item][
[kermit/likes 'goats]
[kermit/likes 'puppets]
[kermit/sound]
[kermit/species]
[kermit/skin]
[kermit/color]
[kermit/eat 'fly]
[kermit/eat 'hamburger]
][
prin [form to-block first item #]
if pick item 2 [
prin join form next item "? "
]
print item
]
if not did [
unset 'kermit
print "Reloading fresh kermit"
;- load the normal way
kermit: do load %kermit-frog.r
did: yes
]
]
;-- Does kermit still dislike grass?
print ["Does kermit eat grass?" kermit/eat 'grass]
{ ;-- results in:
Does kermit eat grass? yuck ;-(base method)
kermit likes goats? ignores ; " "
kermit likes puppets? loves
kermit sound ribbit ribbit ; " "
kermit species amphibian ; " "
kermit skin foam
kermit color 0.188.12
kermit eat fly? yummy ; " "
kermit eat hamburger? gulp
Reloading fresh kermit
kermit likes goats? ignores ; " "
kermit likes puppets? loves
kermit sound It ain't easy being green
kermit species amphibian ; " "
kermit skin foam
kermit color 0.188.12
kermit eat fly? yummy ; " "
kermit eat hamburger? gulp
Does kermit eat grass? yuck ; " "
}
--
To unsubscribe from this list, please send an email to
[EMAIL PROTECTED] with "unsubscribe" in the
subject, without the quotes.
