source: project/release/4/prometheus/prometheus-2/examples/diamond.scm @ 14451

Last change on this file since 14451 was 14451, checked in by sjamaan, 11 years ago

Port Prometheus-2 to Chicken, using the clean, unmodified code from the release

File size: 3.8 KB
Line 
1;;; This requires SRFI-23
2
3;;; We create an amphibious vehicle which inherits from a car - which
4;;; can only drive on ground - and from a ship - which can only drive
5;;; on water. Roads have a type of terrain. The amphibious vehicle
6;;; drives along the road, using either the drive method of the car or
7;;; of the ship.
8
9;;; First, let's build a road.
10(define-object road-segment (*the-root-object*)
11  (next set-next! #f)
12  (type set-type! 'ground)
13  ((clone self resend next type)
14   (let ((o (resend #f 'clone)))
15     (o 'set-next! next)
16     (o 'set-type! type)
17     o)))
18
19;;; Create a road with the environment types in the ENVIRONMENTS list.
20(define (make-road environments)
21  (if (null? (cdr environments))
22      (road-segment 'clone
23                    #f
24                    (car environments))
25      (road-segment 'clone
26                    (make-road (cdr environments))
27                    (car environments))))
28
29;;; Now, we need a vehicle - the base class.
30(define-object vehicle (*the-root-object*)
31  (location set-location! #f)
32  ((drive self resend)
33   #f)
34  ((clone self resend . location)
35   (let ((o (resend #f 'clone)))
36     (if (not (null? location))
37         (o 'set-location! (car location)))
38     o)))
39
40
41;;; All vehicles have to drive quite similarily - no one stops us from
42;;; using a normal helper procedure here.
43(define (handle-drive self handlers)
44  (let ((next ((self 'location) 'next)))
45    (cond
46     ((not next)
47      (display "Yay, we're at the goal!")
48      (newline))
49     ((assq (next 'type) handlers)
50      => (lambda (handler)
51           ((cdr handler) next)))
52     (else
53      (error "Your vehicle crashed on a road segment of type"
54             (next 'type))))))
55
56;;; And a car. Hm. Wait. A CAR is something pretty specific in Scheme,
57;;; make an automobile instead.
58(define-object automobile (vehicle)
59  ((drive self resend)
60   (resend #f 'drive)
61   (handle-drive self `((ground . ,(lambda (next)
62                                     (display "*wrooom*")
63                                     (newline)
64                                     (self 'set-location! next)))))))
65
66;;; And now a ship, for waterways.
67(define-object ship (vehicle)
68  ((drive self resend)
69   (resend #f 'drive)
70   (handle-drive self `((water . ,(lambda (next)
71                                    (display "*whoosh*")
72                                    (newline)
73                                    (self 'set-location! next)))))))
74
75;;; And an amphibious vehicle for good measure!
76(define-object amphibious (ship (ground-parent automobile))
77  ((drive self resend)
78   (handle-drive self `((water . ,(lambda (next)
79                                   (resend 'parent 'drive)))
80                       (ground . ,(lambda (next)
81                                    (resend 'ground-parent 'drive)))))))
82
83
84;;; The code above works already. We can clone ships, automobiles and
85;;; amphibious vehicles as much as we want, and they drive happily on
86;;; roads. But we could extend this, and add gas consumption. This
87;;; will even modify already existing vehicles, because they inherit
88;;; from the vehicle object we extend:
89(vehicle 'add-value-slot! 'gas 'set-gas! 0)
90(vehicle 'add-value-slot! 'needed-gas 'set-needed-gas! 0)
91(define-method (vehicle 'drive self resend)
92  (let ((current-gas (self 'gas))
93        (needed-gas (self 'needed-gas)))
94    (if (>= current-gas needed-gas)
95        (self 'set-gas! (- current-gas needed-gas))
96        (error "Out of gas!"))))
97
98;;; If you want to test the speed of the implementation:
99(define (make-infinite-road)
100  (let* ((ground (road-segment 'clone #f 'ground))
101         (water (road-segment 'clone ground 'water)))
102    (ground 'set-next! water)
103    ground))
104
105(define (test n)
106  (let ((o (amphibious 'clone (make-infinite-road))))
107    (do ((i 0 (+ i 1)))
108        ((= i n) #t)
109      (o 'drive))))
110
Note: See TracBrowser for help on using the repository browser.