;;; -*- Mode: Lisp; Package: Puser; Base: 10. ; Options: ((World Turtle)); -*-
;;; (C) Copyright 1983,1984,1985, Uppsala University

(declare (special *xcor *ycor *heading *turtle *wrap *xorstate *drawstate))

(define-predicate help
  (:options (:argument-list ()))
  ((help)
   (lisp-value ?help prolog:*turtle-help* :dont-invoke)
   (format t "~%~a" ?help)))

;;; Examples. These generate difference lists of Turtle commands.

(define-predicate poly
  (:options (:argument-list (commands commands-end edges size &optional ignore)))
  ((poly ?com ?com ?edges ?)
   ( ?edges 1))
  ((poly ?com0 ?com ?edges ?size)
   (> ?edges 1)
   (quotient ?angle 360. ?edges)
   (poly ?com0 ?com ?angle ?edges 0 ?size))
  ((poly ?com ?com ? ?edges ?edges ?))
  ((poly ((:forward ?size) . ?com0) ?com ?angle ?edges ?fewer ?size)
   (= ?com0 ((:right ?angle) . ?com1))
   (< ?fewer ?edges)
   (sum ?more ?fewer 1)
   (poly ?com1 ?com ?angle ?edges ?more ?size)))
  
(define-predicate circle
  (:options (:argument-list (commands commands-end +size)))
  ((circle ?com0 ?com ?size) (= ?com0 ((:circle ?size) . ?com))))

;;; New cleaned-up Turtle interface to logic.
prolog:
(progn 'compile
(define-predicate puser:turtle-stream
  :(options (world graphics))
  ((puser:turtle-stream ?pos0 ())
   (puser:turtle-stream ?pos0))
  ((puser:turtle-stream ?pos0)
   (lisp-value ?instance (make-instance-in-area *prolog-work-area* 'puser:turtle-stream)
	       :dont-invoke)
   (turtle-stream-server ?instance ((:wipe) . ?pos0))))

(define-predicate puser:turtle-stream-concurrent
  :(options (world graphics))
  ((puser:turtle-stream-concurrent ?pos0 ((:unlock)))
   (lisp-value ?instance (make-instance-in-area *prolog-work-area* 'puser:turtle-stream)
	       :dont-invoke)
   (turtle-stream-server ?instance ((:lock) . ?pos0))))

(define-predicate puser:turtle-stream
  ((puser:turtle-stream . ?)))

(define-predicate turtle-stream-server
  :(options (world graphics))
  ((turtle-stream-server ? ()) (cut))
  ((turtle-stream-server ?instance (?msg . ?pos0))
   (lisp-predicate (apply '?instance '?msg) :invoke)
   (constrain ?pos0 (turtle-stream-server ?instance ?pos0))))
)

(defflavor turtle-stream () ())

(defvar *turtle-lock* nil)

(defun turtle-lock ()
  (or (%store-conditional (locf *turtle-lock*) nil current-process)
      (condition-case ()			;If time out then go ahead and clobber...
	  (process-lock (locf *turtle-lock*) nil "Turtle" #-symbolics 70.)
	(error (setq *turtle-lock* nil)
	       (turtle-lock)))))

(defun turtle-unlock ()
  (%store-conditional (locf *turtle-lock*) current-process nil))

(defmethod (turtle-stream :lock) ()
  (prolog:remind-call 'turtle-unlock)
  (turtle-lock)
  (placeturtle '(0 0 0)))

(defmethod (turtle-stream :unlock) ()
  (prolog:remind-call 'placeturtle (prolog:prolog-list *xcor *ycor *heading))
  (prolog:remind-call 'turtle-lock)
  (turtle-unlock))

(defmethod (turtle-stream :startdisplay) ()
  (startdisplay))

(defmethod (turtle-stream :wipe) ()
  (wipe))

(defmethod (turtle-stream :clearscreen) ()
  (prolog:remind-call 'clearscreen)
  (clearscreen))

(defmethod (turtle-stream :hideturtle) ()
  (prolog:remind-call 'showturtle)
  (hideturtle))

(defmethod (turtle-stream :showturtle) ()
  (prolog:remind-call 'hideturtle)
  (showturtle))

(defmethod (turtle-stream :forward) (steps)
  (prolog:remind-call 'back steps)
  (forward steps))

(defmethod (turtle-stream :back) (steps)
  (prolog:remind-call 'forward steps)
  (back steps))

(defmethod (turtle-stream :delx) (x)
  (prolog:remind-call 'delx (- x))
  (delx x))

(defmethod (turtle-stream :dely) (y)
  (prolog:remind-call 'dely (- y))
  (dely y))

(defmethod (turtle-stream :delxy) (x y)
  (prolog:remind-call 'delxy (- x) (- y))
  (delxy x y))

(defmethod (turtle-stream :home) ()
  (prolog:remind-call 'setturtle (prolog:prolog-list *xcor *ycor *heading))
  (home))

(defmethod (turtle-stream :wrap) ()
  (cond ((not *wrap) (prolog:remind-call 'nowrap)))
  (wrap))

(defmethod (turtle-stream :nowrap) ()
  (cond (*wrap (prolog:remind-call 'wrap)))
  (nowrap))

(defmethod (turtle-stream :right) (steps)
  (prolog:remind-call 'left steps)
  (right steps))

(defmethod (turtle-stream :left) (steps)
  (prolog:remind-call 'right steps)
  (left steps))

(defmethod (turtle-stream :sethead) (steps)
  (prolog:remind-call 'sethead (heading))
  (sethead steps))

(defmethod (turtle-stream :pendown) ()
  (cond ((not *xorstate) (prolog:remind-call 'xorup)))
  (xordown))

(defmethod (turtle-stream :penup) ()
  (cond (*xorstate (prolog:remind-call 'xordown)))
  (xorup))


;;Don't cause rounding errors...
(defmethod (turtle-stream :here) (xcor ycor heading)
  (and (prolog:unify xcor *xcor)
       (prolog:unify ycor *ycor)
       (prolog:unify heading *heading)))

(defmethod (turtle-stream :setturtle) (&rest state)
  (prolog:remind-call 'setturtle (prolog:prolog-list *xcor *ycor *heading))
  (setturtle state))

(defmethod (turtle-stream :placeturtle) (&rest state)
  (prolog:remind-call 'placeturtle (prolog:prolog-list *xcor *ycor *heading))
  (placeturtle state))

(defun placeturtle (state)
  (let (*drawstate) (setturtle state)))

(defmethod (turtle-stream :hatch) (name)
  (cond ((prolog:unbound-variable-p name)
	 (prolog:unify name (prolog:generate-interned-symbol name))
	 (setq name (prolog:%dereference name))))
  (prolog:remind-call 'useturtle *turtle)
  (hatch name))

(defmethod (turtle-stream :useturtle) (name)
  (prolog:remind-call 'useturtle *turtle)
  (useturtle name))

(defmethod (turtle-stream :mark) (text)
  (prolog:remind-call 'mark text)
  (mark text)
  t)

;;The grammar kit needs to display a centered label and skip vertically after.
(defmethod (turtle-stream :markv) (text)
  (prolog:remind-call 'markv text *ycor)
  (markv text nil)
  t)

(defun markv (text up)
  (let-if (symbolp text) ((text (get-pname text)))
    (let (*drawstate) ;inhibit drawing
      (cond ((not up)
	     (send tvrtle-window ':set-cursorpos
		   (- (tv-x *xcor) (// (send tvrtle-window ':string-length text) 2))
		   (+ 5 (tv-y *ycor)))
	     (send tvrtle-window ':string-out text)
	     (dely -30.))
	    (t (sety up)
	       (send tvrtle-window ':set-cursorpos
		     (- (tv-x *xcor) (// (send tvrtle-window ':string-length text) 2))
		     (+ 5 (tv-y *ycor)))
	       (send tvrtle-window ':string-out text))))))

(defmethod (turtle-stream :point) ()
  (prolog:remind-call 'point)
  (point))

(defmethod (turtle-stream :arc) (rad deg)
  (prolog:remind-call 'arc rad deg)
  (arc rad deg))

(defmethod (turtle-stream :circle) (rad)
  (prolog:remind-call 'circle rad)
  (circle rad))

(ADD-WORLD :GRAPHICS)