;;;                        "ontosimula"  (Release 1.0)
;;; A simplified executable model of the principles of "metaphysics"
;;;                    by  George P. Loczewski
;;;                    e-mail: schemer@knuut.de
;;;
;(load "util.scm")

(define  using-mzscheme  #t)

(define make-person-image 
  (lambda(win origin color)
    (letrec ((base-object (make-base-object))
             (w win)
             (org origin)
             (col color)
             (width 14)
             (height 20)
             (frame '?)
             (visible? #t)
             (parts
               (list  (make-posn 5 0)   (make-posn 9 0)    ; head
                      (make-posn 9 0)   (make-posn 9 4)
                      (make-posn 9 4)   (make-posn 5 4)
                      (make-posn 5 4)   (make-posn 5 0)
                      (make-posn 7 4)   (make-posn 7 12)   ; body
                      (make-posn 7 12)  (make-posn 3 20)   ; legs
                      (make-posn 7 12)  (make-posn 11 20)
                      (make-posn 0 20)  (make-posn 3 20)   ; feet
                      (make-posn 11 20) (make-posn 14 20)
                      (make-posn 1 8)   (make-posn 13 8)   ; arms
                      (make-posn 0 9)   (make-posn 1 8)    ; hands
                      (make-posn 13 8)  (make-posn 14 7)))


             (get-type 
               (lambda()
                 "person-image"))

             (get-visible
               (lambda()
                 visible?))

             (set-visible
               (lambda(val)
                 (set! visible? val)))

             (set-color
               (lambda(val)
                 (set! col val)))

             (display
               (lambda()
                 (letrec ((loop  
                            (lambda(l)
                              (unless  (null? l)
                                ((draw-line  w)(add-posn  org  (car l))  
                                         (add-posn  org  (cadr l)) col)
                                (loop  (cddr l))))))
                   (loop parts))))

             (hide
               (lambda()
                 (if org
                     (begin
                       (set! frame 
                             (make-rectangle w org width height 1 COLWHITE))
                       (m-dispatch frame 'paint )))))

             (move
               (lambda(pos)
                 (hide)
                 (set! org pos)
                 (if visible?
                     (display) )))

             (set
               (lambda(pos)
                 (set! org pos)
                 (display) ))

             (self 
                (lambda(msg)
                  (cond
                     ( (eq? msg 'type) get-type )
                     ( (eq? msg 'display) display)
                     ( (eq? msg 'visible?) get-visible)
                     ( (eq? msg 'set-visible) set-visible)
                     ( (eq? msg 'set-color) set-color)
                     ( (eq? msg 'hide) hide)
                     ( (eq? msg 'move) move)
                     ( (eq? msg 'set) set)
                     ( else  (base-object msg ))))))
      self)))

(define make-chopstick-image 
  (lambda(win origin color)
    (letrec ((base-object (make-base-object))
             (w win)
             (org origin)
             (col color)
             (width 7)
             (height 16)
             (frame '?)
             (visible? #f)
             (parts
               (list  (make-posn 0 0)   (make-posn 0 16)))

             (get-type 
               (lambda()
                 "chopstick-image"))

             (get-visible
               (lambda()
                 visible?))

             (set-visible
               (lambda(val)
                 (set! visible? val)))

             (display
               (lambda()
                 (letrec ((loop  
                            (lambda(l)
                              (unless  (null? l)
                                ((draw-line  w)(add-posn  org  (car l))  
                                         (add-posn  org  (cadr l)) col)
                                (loop  (cddr l))))))
                   (loop parts))))

             (hide
               (lambda()
                 (if org
                     (begin
                       (set! frame 
                             (make-rectangle w org width height 1 COLWHITE))
                       (m-dispatch frame 'paint )))))

             (move
               (lambda(pos)
                 (hide)
                 (set! org pos)
                 (if visible? (display) )))

             (set
               (lambda(pos)
                 (set! org pos)
                 (if visible? (display) )))

             (self 
                (lambda(msg)
                  (cond
                     ( (eq? msg 'type) get-type )
                     ( (eq? msg 'display) display)
                     ( (eq? msg 'visible?) get-visible)
                     ( (eq? msg 'set-visible) set-visible)
                     ( (eq? msg 'hide) hide)
                     ( (eq? msg 'move) move)
                     ( (eq? msg 'set) set)
                     ( else  (base-object msg ))))))
      self)))

(define make-rectangle 
  (lambda(win origin width height thick color)
    (letrec ((base-object (make-base-object))
             (w win)
             (org origin)
             (horiz width)
             (vert height)
             (frame thick)
             (col color)

             (get-type 
               (lambda()
                 "rectangle"))

             (get-visible
               (lambda()
                 visible?))

             (set-visible
               (lambda(val)
                 (set! visible? val)))

             (display
               (lambda  ()
                 (letrec ((x0  (posn-x org))  
                          (y0  (posn-y org))

                          (loop 
                            (lambda(lf rt top bot n)
                              (when  (> n 0)
                                ((draw-line w) (make-posn lf top)  
                                               (make-posn rt top) col)
                                ((draw-line w) (make-posn rt top)  
                                               (make-posn rt bot) col)
                                ((draw-line w) (make-posn rt bot)  
                                               (make-posn lf bot) col)
                                ((draw-line w) (make-posn lf bot)  
                                               (make-posn lf top) col)
                                (loop  (+ lf 1)  
                                       (- rt 1)  
                                       (+ top 1)  
                                       (- bot 1)  
                                       (- n 1))))))
                   (loop x0 
                         (+ x0 horiz frame -1) 
                         y0 
                         (+ y0 vert frame -1) 
                         frame))))

             (paint-aux
               (lambda(or hz vt cl)
                 (when  (>= vt 0)
                        (let ((right  (add-hv or hz 0))
                              (next   (add-hv or 0 +1)))
                          ((draw-line w)  or  right cl)
                          (paint-aux  next  hz  (- vt 1) cl)))))

             (paint
               (lambda  ()
                 (paint-aux org (+ 1 horiz) (+ 1 vert) col)))

             (hide
               (lambda()
                 (paint-aux org (+ 1 horiz) (+ 1 vert) COLWHITE)))

             (move
               (lambda(pos)
                 (hide)
                 (set! org pos)
                 (if visible? (display) )))

             (self 
                (lambda(msg)
                  (cond
                     ( (eq? msg 'type) get-type )
                     ( (eq? msg 'display) display)
                     ( (eq? msg 'visible?) get-visible)
                     ( (eq? msg 'set-visible) set-visible)
                     ( (eq? msg 'paint) paint)
                     ( (eq? msg 'hide) hide)
                     ( (eq? msg 'move) move)
                     ( else  (base-object msg ))))))
      self)))

(define  COLBLACK  (make-rgb 0 0 0))
(define  COLBLUE   (make-rgb 0 0 1))
(define  COLGREEN  (make-rgb 0 1 0))
(define  COLLBLUE  (make-rgb 0 1 1))
(define  COLRED    (make-rgb 1 0 0))
(define  COLPINK   (make-rgb 1 0 1))
(define  COLGELB   (make-rgb 1 1 0))
(define  COLWHITE  (make-rgb 1 1 1))

(define make-castle
  (lambda(w)
    (letrec ((base-object (make-base-object))
             (p10 (make-posn 22 32))
             (p1d (add-hv p10 60 -5))
             (p1s (add-hv p10 10 10))
             (p1m (add-hv p1s 20 0))
             (p1t (add-hv p10 30 35))
             (p1k (add-hv p1t 10 0))
             (p1n (add-hv p1k 10 0))
             (p11 (make-posn 15 15))
             (p12 (make-posn 15 105))
             (p13 (make-posn 45 105))
             (p14 (make-posn 75 105))
             (p15 (make-posn 105 105))
             (p16 (make-posn 105 75))
             (p17 (make-posn 105 45))
             (p18 (make-posn 105 15))
             (p20 (make-posn 123 62))
             (p2d (add-hv (make-posn 133 50) 5 0))
             (p2s (add-hv p2d 10 0))
             (p2m (add-hv p2s 20 0))
             (p2t (add-hv p20 30 35))
             (p2k (add-hv p2t 10 0))
             (p2n (add-hv p2k 10 0))
             (p21 (make-posn 180 75))
             (p22 (make-posn 210 75))
             (p30 (make-posn 298 33))
             (p3d (add-hv p30 60 -5))
             (p3s (add-hv p30 10 10))
             (p3m (add-hv p3s 20 0))
             (p3t (add-hv p30 30 35))
             (p3k (add-hv p3t 10 0))
             (p3n (add-hv p3k 10 0))
             (p31 (make-posn 285 15))
             (p32 (make-posn 285 45))
             (p33 (make-posn 285 75))
             (p34 (make-posn 285 105))
             (p35 (make-posn 315 105))
             (p36 (make-posn 345 105))
             (p37 (make-posn 375 105))
             (p38 (make-posn 375 15))
             (p40 (make-posn 48 128))
             (p4d (add-hv p40 0 5))
             (p4s (add-hv p4d 0 20))
             (p4m (add-hv p4s 0 25))
             (p4t (add-hv p40 30 35))
             (p4k (add-hv p4t 10 0))
             (p4n (add-hv p4k 10 0))
             (p41 (make-posn 75 180))
             (p42 (make-posn 75 210))
             (p43 (make-posn 180 120))
             (p44 (make-posn 180 180))
             (p45 (make-posn 180 210))
             (p50 (make-posn 318 128))
             (p5d (add-hv p50 0 5))
             (p5s (add-hv p5d 0 20))
             (p5m (add-hv p5s 0 25))
             (p5t (add-hv p50 30 35))
             (p5k (add-hv p5t 10 0))
             (p5n (add-hv p5k 10 0))
             (p51 (make-posn 315 180))
             (p52 (make-posn 315 210))
             (p53 (make-posn 210 210))
             (p54 (make-posn 210 180))
             (p60 (make-posn 28 303))
             (p6d (add-hv p60 60 -5))
             (p6s (add-hv p60 10 10))
             (p6m (add-hv p6s 20 0))
             (p6t (add-hv p60 30 35))
             (p6k (add-hv p6t 10 0))
             (p6n (add-hv p6k 10 0))
             (p61 (make-posn 15 285))
             (p62 (make-posn 15 375))
             (p63 (make-posn 105 375))
             (p64 (make-posn 105 345))
             (p65 (make-posn 105 315))
             (p66 (make-posn 105 285))
             (p67 (make-posn 75 285))
             (p68 (make-posn 45 285))
             (p70 (make-posn 123 333))
             (p71 (make-posn 180 315))
             (p7d (add-hv (make-posn 133 323) 5 0))
             (p7s (add-hv p7d 15 0))
             (p7m (add-hv p7s 20 0))
             (p7t (add-hv p70 70 -10))
             (p7k (add-hv p7t 10 0))
             (p7n (add-hv p7k 10 0))
             (p72 (make-posn 210 315))
             (p80 (make-posn 296 303))
             (p8d (add-hv p80 60 -5))
             (p8s (add-hv p80 10 10))
             (p8m (add-hv p8s 20 0))
             (p8t (add-hv p8s 20 25))
             (p8k (add-hv p8t 10 0))
             (p8n (add-hv p8k 10 0))
             (p81 (make-posn 285 285))
             (p82 (make-posn 285 315))
             (p83 (make-posn 285 345))
             (p84 (make-posn 285 375))
             (p85 (make-posn 375 375))
             (p86 (make-posn 375 345))
             (p87 (make-posn 375 315))
             (p88 (make-posn 375 285))
             (p89 (make-posn 345 285))
             (p90 (make-posn 315 285))
             (p91 (make-posn 185 185))
             (p92 (make-posn 195 185))
             (p93 (make-posn 205 185))
             
             (display
               (lambda()
                 ((draw-line w) p11 p18 COLBLACK)
                 ((draw-line w) p18 p17 COLBLACK)
                 ((draw-line w) p16 p15 COLBLACK)
                 ((draw-line w) p15 p14 COLBLACK)
                 ((draw-line w) p13 p12 COLBLACK)
                 ((draw-line w) p12 p11 COLBLACK)
                 ((draw-line w) p31 p38 COLBLACK)
                 ((draw-line w) p38 p37 COLBLACK)
                 ((draw-line w) p37 p36 COLBLACK)
                 ((draw-line w) p35 p34 COLBLACK)
                 ((draw-line w) p34 p33 COLBLACK)
                 ((draw-line w) p32 p31 COLBLACK)
                 ((draw-line w) p17 p32 COLBLACK)
                 ((draw-line w) p16 p21 COLBLACK)
                 ((draw-line w) p22 p33 COLBLACK)
                 ((draw-line w) p13 p68 COLBLACK)
                 ((draw-line w) p36 p89 COLBLACK)
                 ((draw-line w) p14 p41 COLBLACK)
                 ((draw-line w) p35 p51 COLBLACK)
                 ((draw-line w) p42 p67 COLBLACK)
                 ((draw-line w) p52 p90 COLBLACK)
                 ((draw-line w) p41 p44 COLGREEN)
                 ((draw-line w) p54 p51 COLGREEN)
                 ((draw-line w) p42 p45 COLGREEN)
                 ((draw-line w) p53 p52 COLGREEN)
                 ((draw-line w) p45 p71 COLGREEN)
                 ((draw-line w) p53 p72 COLGREEN)
                 ((draw-line w) p21 p44 COLGREEN)
                 ((draw-line w) p22 p54 COLGREEN)
                 ((draw-line w) p61 p68 COLBLACK)
                 ((draw-line w) p67 p66 COLBLACK)
                 ((draw-line w) p66 p65 COLBLACK)
                 ((draw-line w) p64 p63 COLBLACK)
                 ((draw-line w) p63 p62 COLBLACK)
                 ((draw-line w) p62 p61 COLBLACK)
                 ((draw-line w) p64 p83 COLBLACK)
                 ((draw-line w) p65 p71 COLBLACK)
                 ((draw-line w) p72 p82 COLBLACK)
                 ((draw-line w) p64 p83 COLBLACK)
                 ((draw-line w) p81 p82 COLBLACK)
                 ((draw-line w) p83 p84 COLBLACK)
                 ((draw-line w) p84 p85 COLBLACK)
                 ((draw-line w) p85 p86 COLBLACK)
                 ((draw-line w) p86 p87 COLGREEN)
                 ((draw-line w) p87 p88 COLBLACK)
                 ((draw-line w) p88 p89 COLBLACK)
                 ((draw-line w) p90 p81 COLBLACK)
                 ((draw-string w) p10  "Parmenides")
                 ((draw-string w) p20  " ")
                 ((draw-string w) p30  "Plato")
                 ((draw-string w) p40  " ")
                 ((draw-string w) p50  " ")
                 ((draw-string w) p60  "Aristoteles")
                 ((draw-string w) p70  "Heraklit")
                 ((draw-string w) p80  "Sokrates")))
             (set-parmenides
               (lambda(s room)
                 (case room
                   ((A) (m-dispatch s 'set p1m))
                   ((B) (m-dispatch s 'set p2m))
                   ((C) (m-dispatch s 'set p3m))
                   ((D) (m-dispatch s 'set p4m))
                   ((E) (m-dispatch s 'set p5m))
                   ((F) (m-dispatch s 'set p6m))
                   ((G) (m-dispatch s 'set p7m))
                   ((H) (m-dispatch s 'set p8m)))))
             (set-plato
               (lambda(s room)
                 (case room
                   ((A) (m-dispatch s 'set p1m))
                   ((B) (m-dispatch s 'set p2m))
                   ((C) (m-dispatch s 'set p3m))
                   ((D) (m-dispatch s 'set p4m))
                   ((E) (m-dispatch s 'set p5m))
                   ((F) (m-dispatch s 'set p6m))
                   ((G) (m-dispatch s 'set p7m))
                   ((H) (m-dispatch s 'set p8m)))))
             (set-aristotle
               (lambda(s room)
                 (case room
                   ((A) (m-dispatch s 'set p1m))
                   ((B) (m-dispatch s 'set p2m))
                   ((C) (m-dispatch s 'set p3m))
                   ((D) (m-dispatch s 'set p4m))
                   ((E) (m-dispatch s 'set p5m))
                   ((F) (m-dispatch s 'set p6m))
                   ((G) (m-dispatch s 'set p7m))
                   ((H) (m-dispatch s 'set p8m)))))
             (set-sokrates
               (lambda(s room)
                 (case room
                   ((A) (m-dispatch s 'set p1m))
                   ((B) (m-dispatch s 'set p2m))
                   ((C) (m-dispatch s 'set p3m))
                   ((D) (m-dispatch s 'set p4m))
                   ((E) (m-dispatch s 'set p5m))
                   ((F) (m-dispatch s 'set p6m))
                   ((G) (m-dispatch s 'set p7m))
                   ((H) (m-dispatch s 'set p8m)))))
             (set-heraklit
               (lambda(s room)
                 (case room
                   ((A) (m-dispatch s 'set p1m))
                   ((B) (m-dispatch s 'set p2m))
                   ((C) (m-dispatch s 'set p3m))
                   ((D) (m-dispatch s 'set p4m))
                   ((E) (m-dispatch s 'set p5m))
                   ((F) (m-dispatch s 'set p6m))
                   ((G) (m-dispatch s 'set p7m))
                   ((H) (m-dispatch s 'set p8m)))))
             (set-chopstick-1
               (lambda(n room)
                 (case room
                   ((A) (m-dispatch n 'set p1t))
                   ((C) (m-dispatch n 'set p3t))
                   ((F) (m-dispatch n 'set p6t))
                   ((G) (m-dispatch n 'set p7t))
                   ((H) (m-dispatch n 'set p8t))
                   ((I) (m-dispatch n 'set p91)))))
             (set-chopstick-2
               (lambda(n room)
                 (case room
                   ((A) (m-dispatch n 'set p1k))
                   ((C) (m-dispatch n 'set p3k))
                   ((F) (m-dispatch n 'set p6k))
                   ((G) (m-dispatch n 'set p7k))
                   ((H) (m-dispatch n 'set p8k))
                   ((I) (m-dispatch n 'set p92)))))
             (set-chopstick-3
               (lambda(n room)
                 (case room
                   ((A) (m-dispatch n 'set p1n))
                   ((C) (m-dispatch n 'set p3n))
                   ((F) (m-dispatch n 'set p6n))
                   ((G) (m-dispatch n 'set p7n))
                   ((H) (m-dispatch n 'set p8n))
                   ((I) (m-dispatch n 'set p93)))))
             (move-chopstick-1
               (lambda(n room)
                 (case room
                   ((A) (m-dispatch n 'move p1t))
                   ((C) (m-dispatch n 'move p3t))
                   ((F) (m-dispatch n 'move p6t))
                   ((G) (m-dispatch n 'move p7t))
                   ((H) (m-dispatch n 'move p8t))
                   ((I) (m-dispatch n 'move p91)))))
             (move-chopstick-2
               (lambda(n room)
                 (case room
                   ((A) (m-dispatch n 'move p1k))
                   ((C) (m-dispatch n 'move p3k))
                   ((F) (m-dispatch n 'move p6k))
                   ((G) (m-dispatch n 'move p7k))
                   ((H) (m-dispatch n 'move p8k))
                   ((I) (m-dispatch n 'move p92)))))
             (move-chopstick-3
               (lambda(n room)
                 (case room
                   ((A) (m-dispatch n 'move p1n))
                   ((C) (m-dispatch n 'move p3n))
                   ((F) (m-dispatch n 'move p6n))
                   ((G) (m-dispatch n 'move p7n))
                   ((H) (m-dispatch n 'move p8n))
                   ((I) (m-dispatch n 'move p93)))))
             (self 
                (lambda(msg)
                  (cond
                     ( (eq? msg 'display) display)
                     ( (eq? msg 'set-parmenides) set-parmenides)
                     ( (eq? msg 'set-plato) set-plato)
                     ( (eq? msg 'set-aristotle) set-aristotle)
                     ( (eq? msg 'set-sokrates) set-sokrates)
                     ( (eq? msg 'set-heraklit) set-heraklit)
                     ( (eq? msg 'set-chopstick-1) set-chopstick-1)
                     ( (eq? msg 'set-chopstick-2) set-chopstick-2)
                     ( (eq? msg 'set-chopstick-3) set-chopstick-3)
                     ( (eq? msg 'move-chopstick-1) move-chopstick-1)
                     ( (eq? msg 'move-chopstick-2) move-chopstick-2)
                     ( (eq? msg 'move-chopstick-3) move-chopstick-3)
                     ( else  (base-object msg ))))))
      self)))

;;
;;  Window primitives for lines, strings, mouse clicks.
;;  These should be the only functions that use *display*.
;;

(define  d-line    #f)
(define  c-line    #f)
(define  d-string  #f)
(define  c-string  #f)

(define  init-window
  (lambda  (horiz  vert)
    (let ((w (open-viewport "Club of Ancient Philosophers" 
                            horiz vert)))
      (set!  d-line  (draw-line  w))
      (set!  c-line  (clear-line  w))
      (set!  d-string  (draw-string w))
      (set!  c-string  (clear-string  w))
      w)))

(define  d-string-bf
  (lambda  (posn  string)
    (d-string  posn  string)
    (d-string  (add-hv posn 1 0)  string)))

(define  c-string-bf
  (lambda  (posn  string)
    (c-string  posn  string)
    (c-string  (add-hv posn 1 0)  string)))

;;
;;  Helper functions for position, offsets, etc.
;;  SIXLib should provide better primitives here.
;;

(define  under?   (lambda  (p1  p2)  (>  (posn-y p1)  (posn-y p2))))

(define  add-posn
  (lambda  (p1  p2)
    (make-posn  (+  (posn-x p1)  (posn-x p2))
                (+  (posn-y p1)  (posn-y p2)))))

(define  add-hv
  (lambda  (p  horiz  vert)
    (make-posn  (+  (posn-x p)  horiz) 
                (+  (posn-y p)  vert))))

;;
;;  Low-level primitives for lines, rectangles, etc.
;;
        
(define  paint-rect
  (lambda  (origin  horiz  vert)
    (when  (>= vert 0)
      (let ((right  (add-hv origin (- horiz 1) 0))
            (next   (add-hv origin 0 +1)))
        (d-line  origin  right COLRED)
        (paint-rect  next  horiz  (- vert 1))))))

(define  outline-rect
  (lambda  (origin  horiz  vert  thick)
    (let* ((x0  (posn-x origin))  (y0  (posn-y origin)))
      (recur  loop  ((lf   x0)  (rt   (+ x0 horiz thick -1))
                     (top  y0)  (bot  (+ y0 vert  thick -1))
                     (n  thick))
        (when  (> n 0)
          (d-line  (make-posn lf top)  (make-posn rt top) COLRED)
          (d-line  (make-posn rt top)  (make-posn rt bot) COLRED)
          (d-line  (make-posn rt bot)  (make-posn lf bot) COLRED)
          (d-line  (make-posn lf bot)  (make-posn lf top) COLRED)
          (loop  (+ lf 1)  (- rt 1)  (+ top 1)  (- bot 1)  (- n 1)))))))

(define  clear-inside-rect
  (lambda  (origin  horiz  vert  thick)
    (recur  loop  ((lf  (add-hv origin thick thick))
                   (rt  (add-hv origin (- horiz (+ thick 1)) thick))
                   (n  thick))
      (when  (< n (- vert (+ 1 (* (- thick 1) 2))))
        (c-line  lf  rt)
        (loop  (add-hv lf 0 +1)  (add-hv rt 0 +1) (+ n 1))))))