A simple minimal OO system for newLISP

[m i c h a e l]

As any bricoleur knows, the best way to serve complex numbers is with a bit of almond bread:

Supercool. And on my favorite kind of bread, too: Fractal's Mandelbread ;-)



m i c h a e l

[m i c h a e l]

(while (michael does coding)

(apply (cormullion (dansfloor $idx))

(catch (lutz) newrelease)

(unify 'Fanda 'OO)

(silent newdep))

LOL :-)

Fantastic example of objects Michael, I like it..so does the gui display ;-)

Thank you! Even though the example was just for fun, I think is shows the potential for doing FOOP in newLISP.



m i c h a e l



P.S. I've been meaning to compliment you on all your great GS programs, Norman, but I'm forever getting distracted by other things and I forget to. So, thanks for all the cool Gags :-)

[m i c h a e l]

I've updated the shapes code.



What's changed: Made the shape's move methods more sensible (moves the whole shape) and used point's + method to implement its move method. Also changed the name of point's oper method (terrible name) to apply. Changed all the methods to use non-polymorphic calls (I kept them in the reorganized sample run, though). Changed the code to be purely functional (no more state changes).



If Lutz finds an implementation of object references he likes, even keeping state won't be a problem.

Code Select Expand

(load "colon.lsp") ; this contains the ':' macro

;; D I S P L A Y A B L E
(define (displayable:string obj) (string obj))
(define (displayable:print obj) (println ((context (obj 0) 'string) obj) ""))

;; P O I N T
(new displayable 'point)
(define (point:point (x 0) (y 0)) (list point x y))
(define (point:string pt) (string (pt 1) "@" (pt 2)))
(define (point:move pt dx dy) (point:+ pt (point dx dy)))
(define (point:+) (point:apply + (args)))
(define (point:-) (point:apply - (args)))
(define (point:*) (point:apply * (args)))
(define (point:apply op ags)
(cons point (apply map (cons op (map (fn (e) (1 e)) ags))))
)

;; S E G M E N T
(new displayable 'segment)
(define (segment:segment (a (point)) (b (point))) (list segment a b))
(define (segment:string sg)
(string (point:string (sg 1)) " to " (point:string (sg 2)))
)
(define (segment:move sg dx dy)
(segment (point:move (sg 1) dx dy) (point:move (sg 2) dx dy))
)

;; T R I A N G L E
(new displayable 'triangle)
(define (triangle:triangle (ab (segment)) (bc (segment)) (ca (segment)))
(list triangle ab bc ca)
)
(define (triangle:string tr)
(string
(segment:string (tr 1)) ", "
(segment:string (tr 2)) ", "
(segment:string (tr 3))
)
)
(define (triangle:move tr dx dy)
(triangle
(segment:move (tr 1) dx dy)
(segment:move (tr 2) dx dy)
(segment:move (tr 3) dx dy)
)
)

;; S A M P L E   R U N
(println "nMaking three points:")
(:print (set 'a (point)))
(:print (set 'b (point 20 0)))
(:print (set 'c (point 10 5)))

(println "nPoint addition, subtraction, and multiplication:")
(:print (point:+ a b c))
(:print (point:- a b c))
(:print (point:* (point 2 43) '(point 22 1) c))

(println "nMaking a triangle:")
(:print (set 'tri (triangle (segment a b) (segment b c) (segment c a))))

(println "nMove the triangle by delta (30 5):")
(:print (set 'tri (:move tri 30 5)))

(println)

;; E N D


The output:

Code Select Expand


Making three points:
0@0
20@0
10@5

Point addition, subtraction, and multiplication:
30@5
-30@-5
440@215

Making a triangle:
0@0 to 20@0, 20@0 to 10@5, 10@5 to 0@0

Move the triangle by delta (30 5):
30@5 to 50@5, 50@5 to 40@10, 40@10 to 30@5



m i c h a e l

[Lutz]

I think we pretty much nailed it with (1) FOOP based on the colon : operator for polymorphism, (2) objects represented as lists, whose first element is the class they belong too, and (3) classes represented by contexts/namespaces (4) using the default functor of a class-context to hold the object constructor. Even without some mechanism for object references, FOOP is very useful as a simple OO system for newLISP.



Code written this way is almost as speed-efficient as non FOOP code. The overhead required by the colon : function for resolution of context (taken from the object) is minimal.



Michaels code from above is a good reference example to show how it works. The meanwhile the built in colon : operator (to be released in development version 9.2.5) runs all of Michaels FOOP code identical to the hand-written macro.



Perhaps Michael can add his mapping/polymorphism example, he showed earlier, to this example code. It shows that there is no problem of currying and mapping FOOP functions on to a list of objects of different type. The example code could be added to the distribution as it shows all critical elements of FOOP.



The chapter about contexts and OO programming in newLISP will be completely rewritten introducing the colon : operator.



Perhaps somebody would like to write the "Introduction to FOOP" ?



Lutz

[cormullion]

Perhaps somebody would like to write the "Introduction to FOOP" ?

I would certainly like to read it... :-)

[m i c h a e l]

I've been working through the examples in my beloved Booch book, attempting to better understand FOOP. My shift to objects free of side effects was unintended and happened quite naturally. Yes, it requires a different way of thinking about the proper way to do OOP. But considering the failure of OO to live up to its early promises, maybe the time has come to rethink OOP in light of FP. FOOP feels like the best of both worlds.



 I've already grown quite comfortable coding this way and think it fits naturally with newLISP's functional style. I'd still like generated accessors, but doing straight indexing isn't as bad as I thought. Other than that, I'm really happy programming FOOly :-)



I hope to post the latest example (an automatic gardener for a hydroponics farm) as soon as I can stop obsessing over constructing objects completely of objects (ie., no naked numbers, strings, lists, etc.). This  allows keyword-like functionality within methods, as well as being a self-describing data structure.



m i c h a e l



P.S. If no one has any objections, I volunteer myself for FOOP introduction duty ;-)

[m i c h a e l]

The overhead required by the colon : function for resolution of context (taken from the object) is minimal.

For what I thought were reasons of efficiency, I added the contexts to all of the methods in the shapes code (the objects weren't used polymorphicly, anyway). Was this unnecessary?

Perhaps Michael can add his mapping/polymorphism example, he showed earlier, to this example code.

Okay :-)

The example code could be added to the distribution as it shows all critical elements of FOOP.

Oh no. Now the pressure's on ;-)



m i c h a e l

[m i c h a e l]

Here's some more pretend code, where new accepts any number of contexts:

Code Select Expand

(define foo:who)
(define bar:boo)
(define baz:zoo)
(new foo bar baz 'boo)
(symbols boo) ;=> (boo:boo boo:who boo:zoo)
(context 'moo)
(new foo bar baz)
(context MAIN)
(symbols moo) ;=> (moo:boo moo:who moo:zoo)


Instead, it could be a new function (say, mixin)?

Code Select Expand

(define foo:who)
(define bar:boo)
(define baz:zoo)
(mixin foo bar baz 'boo)
(symbols boo) ;=> (boo:boo boo:who boo:zoo)


Or even:

Code Select Expand

(mixin 'boo foo bar baz)


m i c h a e l

[Fanda]

This should make you a mixin expert, Cormullion!



(example and graph representation here)



If you think of mixins as rubber stamps, it's like we're stamping simpler contexts onto progressively more complex ones...

I like graph representation, so for anybody, who likes to play with graphs, you can use yEd - Java™ Graph Editor:

http://www.yworks.com/en/products_yed_about.htm">http://www.yworks.com/en/products_yed_about.htm

from yWorks:

http://www.yworks.com/en/index.html">http://www.yworks.com/en/index.html



After installation see Help - Example Graphs.



Have fun, Fanda



PS: There is also http://www.graphviz.org/">http://www.graphviz.org/  ;-)

[m i c h a e l]

Fanda,



Thanks for pointing out this cool diagramming program! I've already downloaded yEd and am looking forward to seeing what I can do with it.



m i c h a e l



P.S. Graphviz is cool, too, but I already have that one ;-)

[kinghajj]

Looking at Michael's code, I noticed that there are many redundancies with making classes. How about a macro to define classes?

Code Select Expand

;; D I S P L A Y A B L E
(define-class (displayable)
   (define (string)
      (string self))
   (define (print)
      (println (:string self))))

;; P O I N T
(define-class (point (x 0) (y 0))
   (inherits displayable)
   (define (string)
      (string (:x self) "@" (:y self)))
   (define (move dx dy)
      (point:+ self (point dx dy)))
   (define (+) (point:apply + (args)))
   (define (-) (point:apply - (args)))
   (define (*) (point:apply * (args)))
   (define (apply op ags)
      (cons point (apply map (cons op (map (fn (e) (1 e)) ags))))))

;; S E G M E N T
(define-class (segment (a (point)) (b (point)))
   (inherits displayable)
   (define (string)
      (string (:string (:a self)) " to " (:string (:b self))))
   (define (move dx dy)
      (segment (:move (:a self) dx dy) (:move (:b self) dx dy))))

;; T R I A N G L E
(define-class (triangle (ab (segment)) (bc (segment)) (ca (segment)))
   (inherits displayable)
   (define (string)
      (string
         (:string (:ab self)) ", "
         (:string (:bc self)) ", "
         (:string (:ca self))))
   (define (move dx dy)
      (triangle
         (:move (:ab self) dx dy)
         (:move (:bc self) dx dy)
         (:move (:ca self) dx dy))))


As you can see, in my idea, all methods take an implicit "self" argument, and getters/setters for all object variables are automatically defined. There is also a simple way to specify inheritance.



I've begun work on a macro to do this, but it might take me a while. Perhaps this macro could be done better in the C API.

[kinghajj]

OK, Here's the code to my "define-class" macro. There's one little issue with the attribute setters, in that they do not modify the original data, but rather make a new object with the changed attribute. However, because newLISP encourages this sort of style, maybe it will stay this way.

Code Select Expand


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define-class.nlsp
;; by Samuel Fredrickson <kinghajj>
;; Version 0.1, 2007-11-08
;;
;; This "macro" (it's really an entire context) lets newLISP programmers write
;; classes in an easier way. The classes and objects produced by this class
;; follow the standard set in
;; http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1955 by Lutz, and uses some
;; techniques by Michael in that same thread.

; The object-colon macro, by Lutz and Michael. This might become a builtin macro
; in the next version of newLISP, and this will be removed if that happens.
(define-macro (: _func _obj)
(let (_data (eval _obj))
(apply (sym _func (_data 0)) (cons _data (map eval (args))))))

(context 'define-class)

; In Michael's example of "FOOP", he uses defaults in constructor arguments so
; that objects can be created without specifying any arguments. Because that is
; valid newLISP code and has good uses, this function takes the variable names
; and their defaults and extracts just the variable names.
(define (extract-class-vars vars)
(map
(lambda (var)
(if (list? var)
(first var)
(if (symbol? var)
item)))
vars))

; Tests if a list is a method.
(define (method? meth?)
(or
(= (first meth?) 'define)
(= (first meth?) 'define-macro)))

; Extracts methdods from a list.
(define (extract-methods lst)
(filter method? lst))

; Tests if a list specifies a superclass.
(define (inherits? inh?)
(= (sym (first inh?)) 'inherits))

; Returns the name of the superclass.
(define (extract-superclass lst)
((filter inherits? lst) 0 1))

; Fills in missing parts of a method.
(define (mess-up-method method)
(letn
((method-type (first method))
(method-name (sym (method 1 0) class-name))
(method-args (cons method-name (1 (method 1))))
(method-body (2 method)))
(cons method-type (cons method-args method-body))))

; Creates the class context and its constructor.
(define (construct-class)
(let
((constructor-name (cons (sym class-name class-name) class-vars-plain)))
(if class-superclass
(new class-superclass class-name)
(context class-name))
(eval
(list
'define
constructor-name
(cons 'list (cons class-name class-vars))))))

; Creates a getter/setter function for a variable.
(define (create-getter-setter var idx)
(let
((getter-setter-name (sym var class-name)))
(set getter-setter-name
(expand
'(lambda-macro (self value)
(if (setq value (eval value))
(set-nth idx (eval self) value)
((eval self) idx))) 'idx))))

; This is the meat of the macro.
(define-macro (define-class:define-class init)
(letn
((clargs (args))
(class-name (init 0))
(class-superclass (extract-superclass clargs))
(class-vars-plain (1 init))
(class-vars (extract-class-vars class-vars-plain))
(class-methods (map mess-up-method (extract-methods clargs))))
(construct-class)
(map eval class-methods)
(dolist (var class-vars)
(create-getter-setter var (+ $idx 1)))))


Here is an example usage, based on Michael's code. The main difference between this and the idea I posted yesterday is that methods here do not implicitly take self, so it must be specified, a la Python.

Code Select Expand


;; Example usage of define-class, based on code by Michael.
(load "define-class.nlsp")

(define-class (displayable)
(define (string self)
(string self))
(define (print self)
(println (:string self))))

(define-class (point (x 0) (y 0))
(inherits displayable)
(define (string self)
(string "(" (:x self) ", " (:y self) ")"))
(define (move self dx dy)
(point:+ self (point dx dy)))
(define (+) (point:apply + (args)))
(define (-) (point:apply - (args)))
(define (*) (point:apply * (args)))
(define (apply op ags)
(cons point (apply map (cons op (map (fn (e) (1 e)) ags))))))

(define-class (segment (a (point)) (b (point)))
(inherits displayable)
(define (string self)
(string (:string (:a self)) " to " (:string (:b self))))
(define (move self dx dy)
(segment (:move (:a self) dx dy) (:move (:b self) dx dy))))

(define-class (triangle (ab (segment)) (bc (segment)) (ca (segment)))
(inherits displayable)
(define (string self)
(string
(:string (:ab self)) ", "
(:string (:bc self)) ", "
(:string (:ca self))))
(define (move self dx dy)
(triangle
(:move (:ab self) dx dy)
(:move (:bc self) dx dy)
(:move (:ca self) dx dy))))

(println "nMaking three points:")
(:print (set 'a (point)))
(:print (set 'b (point 20 0)))
(:print (set 'c (point 10 5)))

(println "nPoint addition, subtraction, and multiplication:")
(:print (point:+ a b c))
(:print (point:- a b c))
(:print (point:* (point 2 43) '(point 22 1) c))

(println "nMaking a triangle:")
(:print (set 'tri (triangle (segment a b) (segment b c) (segment c a))))

(println "nMove the triangle by delta (30 5):")
(:print (set 'tri (:move tri 30 5)))

(println)


[m i c h a e l]

There's one little issue with the attribute setters, in that they do not modify the original data, but rather make a new object with the changed attribute.

Although I'm still working my way through understanding the potential of functional object-oriented programming, I would say this particular characteristic—immutable objects—seems the most natural way to make objects functional.



This idea isn't so far-fetched, either. At the cellular level, we are not the same bodies we were when we started. Cells die off, replaced by new cells constantly. Creating a new object each time may seem wasteful, but since a list is used to represent objects, the overhead is negligible.



It's possible to do object references by using and passing symbols, but after spending time with the shapes and hydroponic garden examples, I'm less inclined to introduce the added complexity. If we wanted to do objects the "regular" way, as Lutz points out often, there are better languages to turn to. But I see something in newLISP I've not seen in other languages. newLISP feels like an individual's language. A language where one person is able to do grand things because of the simplicity it encourages.



I'm posting the current state of the shapes code. I've bummed it quite a bit and added a little more complexity ;-)

Code Select Expand

;; M I X I N
(constant (global 'mixin)
(fn () (set 's (args -1))  (map (fn (e) (new e s)) (0 -1 (args))))
)

;; D I S P L A Y A B L E
(define (displayable:print   d) (print ((context (d 0) 'string) d)))
(define (displayable:println d) (set 's (:print d))  (println)  s)
(define (displayable:string  d) (string d))
(define (displayable? d) (set 'c (d 0)) (and c:string c:print c:println true))

;; C O M P A R A B L E
(define (comparable:=)  (apply =  (map rest (args))))
(define (comparable:<)  (apply <  (map rest (args))))
(define (comparable:>)  (apply >  (map rest (args))))
(define (comparable:<=) (apply <= (map rest (args))))
(define (comparable:>=) (apply >= (map rest (args))))
(define (comparable:!=) (apply != (map rest (args))))
(define (comparable? n) (set 'c (n 0)) (and c:= c:< c:> c:<= c:>= c:!= true))

;; R O T A T A B L E
(define (rotatable:rotate r rv) (cons (r 0) (rotate (rest r) rv)))
(define (rotatable? r) (true? (context (r 0) 'rotate)))

;; N U M E R I C
(define (numeric:+)   (numeric:apply +   (args)))
(define (numeric:-)   (numeric:apply -   (args)))
(define (numeric:*)   (numeric:apply *   (args)))
(define (numeric:add) (numeric:apply add (args)))
(define (numeric:sub) (numeric:apply sub (args)))
(define (numeric:mul) (numeric:apply mul (args)))
(define (numeric:apply op ags)
(cons (ags 0 0) (apply map (cons op (map (fn (e) (1 e)) ags))))
)
(define (numeric? n) (set 'c (n 0)) (and c:+ c:- c:* c:add c:sub c:mul true))

;; P O I N T
(mixin displayable comparable numeric 'point)
(define (point:point (x 0) (y 0)) (list point x y))
(define (point:move p dx dy) (:+ p (point dx dy)))
(define (point:distance p o)
  (sqrt (add (pow (sub (o 1) (p 1)) 2) (pow (sub (o 2) (p 2)) 2)))
)
(define (point:string p) (string (p 1) "@" (p 2)))
(define (point? p) (= (p 0) point))

;; S E G M E N T
(mixin displayable comparable rotatable 'segment)
(define (segment:segment (a (point)) (b (point))) (list segment a b))
(define (segment:distance s) (:distance (s 1) (s 2)))
(define (segment:move s dx dy)
(segment (:move (s 1) dx dy) (:move (s 2) dx dy))
)
(define (segment:move-point s p dx dy)
(case p
(1 (segment (:move (s 1) dx dy) (s 2)))
(2 (segment (s 1) (:move (s 2) dx dy)))
)
)
(define (segment:string s)
(string "(" (:string (s 1)) " " (:string (s 2)) ")")
)
(define (segment? s) (= (s 0) segment))

;; S H A P E
(mixin displayable comparable rotatable 'shape)

;; T R I A N G L E
(new shape 'triangle)
(define (triangle:triangle (ab (segment)) (bc (segment)) (ca (segment)))
(list triangle ab bc ca)
)
(define (triangle:move t dx dy)
(triangle (:move (t 1) dx dy) (:move (t 2) dx dy) (:move (t 3) dx dy))
)
(define (triangle:move-segment t s dx dy)
(set 't (:rotate t (- s 1)))
(triangle
(:move (t 1) dx dy)
(:move-point (t 2) 1 dx dy)
(:move-point (t 3) 2 dx dy)
)
)
(define (triangle:string t)
(string "(" (:string (t 1)) " " (:string (t 2)) " " (:string (t 3)) ")")
)
(define (triangle? t) (= (t 0) triangle))

;; R E C T A N G L E
(new shape 'rectangle)
(define (rectangle:rectangle (width (segment)) (height (segment)))
(list rectangle width height)
)
(define (rectangle:width r)     (:distance (r 1)))
(define (rectangle:height r)    (:distance (r 2)))
(define (rectangle:perimeter r) (mul (add (:width r) (:height r)) 2))
(define (rectangle:area r)      (mul (:width r) (:height r)))
(define (rectangle:move r dx dy)
(rectangle (:move (r 1) dx dy) (:move (r 2) dx dy))
)
(define (rectangle:string r)
(string "(" (:string (r 1)) " " (:string (r 2)) ")")
)
(define (rectangle? r) (= (r 0) rectangle))

;; S A M P L E   R U N
(println "nMaking three points:")
(:println (set 'a (point)))
(:println (set 'b (point 20 1)))
(:println (set 'c (point 10 5)))

(println "nPerforming point addition, subtraction, and multiplication:")
(:println (:+ a b c))
(:println (:- a b c))
(:println (:* (point 2 43) '(point 22 1) c))

(println "nPerforming the same operations with floats:")
(:println (:add (point 23.4 65.4) (point 33.2) (point 54.6 93.1)))
(:println (:sub (point 23.4 65.4) (point 33.2) (point 54.6 93.1)))
(:println (:mul (point 2.5 43.2) '(point 22.1 1.5) c))

(println "nComparing points (=, <, >=, etc.):")
(println (:= a b c))
(println (:= (point (* 10 2) 1) '(point 20 1) b))
(println (:< a b c))
(println (:> b c a))
(println (:< a b c))
(println (:!= a b c))

(println "nMaking three segments:")
(:println (set 'ab (segment a b)))
(:println (set 'bc (segment b c)))
(:println (set 'ca (segment c a)))

(println "nChecking the distance between a segment's points:")
(map println (map (curry :distance) (list ab bc ca)))

(println "nComparing segments:")
(println (:= ab bc ca))
(println (:= ab (segment a b) (list segment a b)))
(println (:< bc ca))
(println (:> bc ca))
(println (:!= ab bc ca))

(println "nRotating a segment one revolution:")
(:println (:rotate ab 1))

(println "nMoving segment ab's a point and ca's b point by (5 5):")
(:println (set 'ab (:move-point ab 1 5 5)))
(:println (set 'ca (:move-point ca 2 5 5)))

(println "nMaking a triangle:")
(:println (set 'tri (triangle ab bc ca)))

(println "nMoving the triangle by (30 5):")
(:println (set 'tri (:move tri 30 5)))

(println "nMoving the triangle's ab segment by (11 11):")
(:println (set 'tri (:move-segment tri 1 11 11)))

(println "nRotating the triangle full circle:")
(:println (:rotate tri 1))
(:println (:rotate tri 2))
(:println (:rotate tri 3))

(println "nMaking a rectangle:")
(:println (set 'rec (rectangle bc ca)))

(println "nChecking the rectangle's width, height, area, and perimeter:")
(println (:width rec))
(println (:height rec))
(println (:area rec))
(println (:perimeter rec))

(println "nPolymorphically sending 'move' and 'println' to a list of shapes:")
(map (curry :println) (map (fn (e) (:move e 12 12)) (list a ab tri rec)))

(println)

;; T H E  E N D


Also, for anyone interested: I made an alternative version in which the def-type macro allows for attribute defaults and a type predicate. The accessors have also been simplified to be regular functions. But be forewarned: Lutz prefers the clarity of the above code :-)

Code Select Expand

(define-macro (def-type)
(letn
(
ctx (context (args 0 0))
defs (1 (args 0))
atts (if (list? (defs 0)) (map first defs) defs)
lst (cons 'list (cons ctx atts))
)
(set
(default ctx) (expand '(lambda defs lst) 'defs 'lst)
(sym (string ctx "?") MAIN)
(letex (ctxs (string ctx)) '(lambda (o) (= (string (o 0)) ctxs)))
)
(dolist (item atts)
(set
'idx (+ $idx 1)
(sym item ctx) (expand
'(lambda (o v) (if v (set-nth (o idx) v) (o idx)))
'idx
)
)
)
ctx
)
)


And here's the shapes code modified to use def-type and the resulting accessors:

Code Select Expand

;; D E P E N D E N C I E S
(load "def-type.lsp")

;; M I X I N
(constant (global 'mixin)
(fn () (set 's (args -1))  (map (fn (e) (new e s)) (0 -1 (args))))
)

;; D I S P L A Y A B L E
(define (displayable:print   d) (print ((context (d 0) 'string) d)))
(define (displayable:println d) (set 's (:print d))  (println)  s)
(define (displayable:string  d) (string d))
(define (displayable? d) (set 'c (d 0)) (and c:string c:print c:println true))

;; C O M P A R A B L E
(define (comparable:=)  (apply =  (map rest (args))))
(define (comparable:<)  (apply <  (map rest (args))))
(define (comparable:>)  (apply >  (map rest (args))))
(define (comparable:<=) (apply <= (map rest (args))))
(define (comparable:>=) (apply >= (map rest (args))))
(define (comparable:!=) (apply != (map rest (args))))
(define (comparable? n) (set 'c (n 0)) (and c:= c:< c:> c:<= c:>= c:!= true))

;; R O T A T A B L E
(define (rotatable:rotate r rv)
(cons (r 0) (rotate (rest r) rv))
)
(define (rotatable? r) (true? (context (r 0) 'rotate)))

;; N U M E R I C
(define (numeric:+)   (numeric:apply +   (args)))
(define (numeric:-)   (numeric:apply -   (args)))
(define (numeric:*)   (numeric:apply *   (args)))
(define (numeric:add) (numeric:apply add (args)))
(define (numeric:sub) (numeric:apply sub (args)))
(define (numeric:mul) (numeric:apply mul (args)))
(define (numeric:apply op ags)
(cons (ags 0 0) (apply map (cons op (map (fn (e) (1 e)) ags))))
)
(define (numeric? n) (set 'c (n 0)) (and c:+ c:- c:* c:add c:sub c:mul true))

;; P O I N T
(def-type (point (x 0) (y 0)))
(mixin displayable comparable numeric 'point)
(define (point:move p dx dy) (:+ p (point dx dy)))
(define (point:distance p o)
  (sqrt (add (pow (sub (:x o) (:x p)) 2) (pow (sub (:y o) (:y p)) 2)))
)
(define (point:string p) (string (:x p) "@" (:y p)))

;; S E G M E N T
(def-type (segment (a (point)) (b (point))))
(mixin displayable comparable rotatable 'segment)
(define (segment:distance s) (:distance (:a s) (:b s)))
(define (segment:move s dx dy)
(segment (:move (:a s) dx dy) (:move (:b s) dx dy))
)
(define (segment:move-point s p dx dy)
(case p
(1 (segment (:move (:a s) dx dy) (:b s)))
(2 (segment (:a s) (:move (:b s) dx dy)))
)
)
(define (segment:string s)
(string "(" (:string (:a s)) " " (:string (:b s)) ")")
)

;; S H A P E
(mixin displayable comparable rotatable 'shape)

;; T R I A N G L E
(def-type (triangle (ab (segment)) (bc (segment)) (ca (segment))))
(new shape 'triangle)
(define (triangle:move t dx dy)
(triangle (:move (:ab t) dx dy) (:move (:bc t) dx dy) (:move (:ca t) dx dy))
)
(define (triangle:move-segment t s dx dy)
(set 't (:rotate t (- s 1)))
(triangle
(:move (:ab t) dx dy)
(:move-point (:bc t) 1 dx dy)
(:move-point (:ca t) 2 dx dy)
)
)
(define (triangle:string t)
(string
"(" (:string (:ab t)) " " (:string (:bc t)) " " (:string (:ca t)) ")"
)
)

;; R E C T A N G L E
(def-type (rectangle (width (segment)) (height (segment))))
(new shape 'rectangle)
(define (rectangle:width r) (:distance (r 1)))
(define (rectangle:height r) (:distance (r 2)))
(define (rectangle:perimeter r) (mul (add (:width r) (:height r)) 2))
(define (rectangle:area r) (mul (:width r) (:height r)))
(define (rectangle:move r dx dy)
(rectangle (:move (r 1) dx dy) (:move (r 2) dx dy))
)
(define (rectangle:string r)
(string "(" (:string (r 1)) " " (:string (r 2)) ")")
)

;; S A M P L E   R U N
(println "nMaking three points:")
(:println (set 'a (point)))
(:println (set 'b (point 20 1)))
(:println (set 'c (point 10 5)))

(println "nPerforming point addition, subtraction, and multiplication:")
(:println (:+ a b c))
(:println (:- a b c))
(:println (:* (point 2 43) '(point 22 1) c))

(println "nPerforming the same operations with floats:")
(:println (:add (point 23.4 65.4) (point 33.2) (point 54.6 93.1)))
(:println (:sub (point 23.4 65.4) (point 33.2) (point 54.6 93.1)))
(:println (:mul (point 2.5 43.2) '(point 22.1 1.5) c))

(println "nComparing points (=, <, >=, etc.):")
(println (:= a b c))
(println (:= (point (* 10 2) 1) '(point 20 1) b))
(println (:< a b c))
(println (:> b c a))
(println (:< a b c))
(println (:!= a b c))

(println "nMaking three segments:")
(:println (set 'ab (segment a b)))
(:println (set 'bc (segment b c)))
(:println (set 'ca (segment c a)))

(println "nChecking the distance between a segment's points:")
(map println (map (curry :distance) (list ab bc ca)))

(println "nComparing segments:")
(println (:= ab bc ca))
(println (:= ab (segment a b) (list segment a b)))
(println (:< bc ca))
(println (:> bc ca))
(println (:!= ab bc ca))

(println "nRotating a segment one revolution:")
(:println (:rotate ab 1))

(println "nMoving segment ab's a point and ca's b point by (5 5):")
(:println (set 'ab (:move-point ab 1 5 5)))
(:println (set 'ca (:move-point ca 2 5 5)))

(println "nMaking a triangle:")
(:println (set 'tri (triangle ab bc ca)))

(println "nMoving the triangle by (30 5):")
(:println (set 'tri (:move tri 30 5)))

(println "nMoving the triangle's ab segment by (11 11):")
(:println (set 'tri (:move-segment tri 1 11 11)))

(println "nRotating the triangle full circle:")
(:println (:rotate tri 1))
(:println (:rotate tri 2))
(:println (:rotate tri 3))

(println "nMaking a rectangle:")
(:println (set 'rec (rectangle bc ca)))

(println "nChecking the rectangle's width, height, area, and perimeter:")
(println (:width rec))
(println (:height rec))
(println (:area rec))
(println (:perimeter rec))

(println "nPolymorphically sending 'move' and 'println' to a list of shapes:")
(map (curry :println) (map (fn (e) (:move e 12 12)) (list a ab tri rec)))

(println)

;; T H E  E N D


I guess that's enough code for now ;-)



m i c h a e l

[cormullion]

I'm http://www.alh.net/newlisp/phpbb/viewtopic.php?t=1689">voting for you, michael ! :-)

[m i c h a e l]

I'm voting for you, michael ! :-)

Wow, thank you! I didn't even know this could be entered. But it still doesn't hold a candle to your regex GS program :-)



m i c h a e l



P.S. Now we're officialy members of the MAS (Mutual Admiration Society ;-)