;;; -*- Mode:Common-Lisp; Package:TV; Base:10 -*-

(defvar eh:*source-code-debuggable-forms* nil)

(defvar zwei:*section-defining-items* nil)

(defvar w:*windows-to-leave-exposed* nil)

(if (not (get 'ip:*tcp-stream-whostate* 'special))
    (proclaim '(special ip:*tcp-stream-whostate*))
    nil
)

;-------------------------------------------------------------------------------

tv:
(defun tv:my-fasd-symbol-value (filename symbol &optional file-attribute-plist)
  "Write an XLD file named FILENAME containing SYMBOL's value.
Loading the file will set the symbol back to the same value."
  (let* ((compiler:fasd-package nil)
	 (outpath (fs:merge-pathname-defaults
		    filename fs:load-pathname-defaults
		    (compiler:target-binary-file-type compiler:fasd-target)))
	 (compiler:fasd-target (compiler:processor-type-for-file outpath)))
    (with-open-file
      (compiler:fasd-stream outpath
		   :characters nil :direction :output :byte-size 16.
		   :If-Exists :supersede)
      (compiler:locking-resources
	(compiler:fasd-initialize)
	(compiler:fasd-start-file)
	(compiler:fasd-attributes-list
	  (or file-attribute-plist
	      '(:package :user)))
	(compiler:inhibit-gc-flips
	  (compiler:fasd-form `(setq ,symbol ',(symbol-value symbol)) t))
	(compiler:fasd-end-whack)
	(compiler:fasd-end-file))
      (send compiler:fasd-stream :truename))))

tv:
(defun fontify-string (string font)
"
 Given a normal string and a font it returns a fat string, whose chars are in
 the font Font.
"
  (let ((length (length (the string string))))
       (let ((fat-string (make-array length :element-type 'sys:fat-char)))
	    (loop for i from 0 to (- length 1) do
		  (setf (aref fat-string i) (code-char (aref string i) 0 font))
	    )
	    fat-string
       )
  )
)


(defmacro sys:defstruct-safe (&rest args)
  `(defstruct ,@args)
)

(export 'sys:defstruct-safe 'ticl)

(format:defformat format: (:One-Arg) (arg params)
  (let ((display-as (if (consp arg)
			(if (< (length arg) 3)
			    (first arg)
			    (third arg)
			)
		    )
        )
	(slashify (if (consp arg) (second arg) t))
       )
       (format:format-ctl-ascii display-as params slashify)
  )
)

(defmacro letf (varlist &rest body &environment environ)
  "This is like let but uses the BIND primitive."
  `(let ((.values.))				;
     ,@(nreverse (loop for (var val) in varlist collect `(push ,val .values.)))
     ,@(loop for (var val) in varlist
	     for expanded = (macroexpand `(locf ,var) environ)
	     when (and (consp expanded) (eq 'funcall (first expanded))
		       (consp (second expanded))
		       (eq 'function (first (second expanded)))
		       (not (fdefinition-safe (second (second expanded))))
		  )
	     do (compiler:warn 'unknown-letf-locative :probable-error
			       "No known LOCF expander for the form ~S.  ~
                                You probably cannot use LETF with this accessor form." var)
	     collecting `(bind (locf ,var) (pop .values.)))
     . ,body)
  )

;;SPR 149: Don't get blocked by ZWEI:LETF being present
(eval-when (compile load eval)
  (multiple-value-bind (found? status)
      (find-symbol "LETF" "ZWEI")
    (when (and found? (neq status :inherited))
      (unintern 'zwei:letf "ZWEI"))))
(export 'letf "TICL")

;;;=============================================================================



;;; This file contains the definitions of two macros called Assign-Using-Menu
;;; and Values-using-Menu.  They are designed to provide a cleaner interface to
;;; choose-variable-values.

tv:
(defun clean-up-choices (margin-choices)
"Taken from the body of choose-variable-values."
  (mapcar #'(lambda (x)
	      (list (if (atom x) x (car x)) nil
		    'choose-variable-values-choice-box-handler
		    nil nil (if (atom x) nil (cadr x))))
	  margin-choices)
)

tv:
(defun just-call-window (window-location superior near-mode margin-choices osw)
"Taken from the body of choose-variable-values."
  (let ((window (symbol-value window-location))
	(processed-message nil)
	(margin-choices (clean-up-choices margin-choices))
       )
       (let ((current-window
	       (if (send superior :operation-handled-p
			 :set-selection-substitute)
		   superior
		   (or osw mouse-sheet)))
	     (old-substitute (send superior :selection-substitute)))
	 (unwind-protect
	     (progn
	       (clear-input window)
	       (delaying-screen-management
		 (expose-window-near window near-mode)
		 (send window :select)  
		 (send current-window :send-if-handles
		       :set-selection-substitute window))
	       (do () (nil)
		 ;; wait for something from the keyboard.
		 (let ((kbd-intercepted-characters
			 choose-variable-values-intercepted-characters))
		   (process-wait "Choose" #'listen window)
		   (and (setq processed-message
			      (choose-variable-values-process-message
				window (read-any window)))
			(return)))))
	   (delaying-screen-management
	     (send window :deactivate)
	     (send current-window :send-if-handles
		   :set-selection-substitute old-substitute)
	     (and osw (send osw :select nil))))
	 (if (eq processed-message 'exit)
	     (execute-margin-choice margin-choices
	       w:margin-choice-completion-string
	       #'ignore)
	     ;;else
	     (if (eq processed-message 'abort)
		 (execute-margin-choice
		   margin-choices
		   w:margin-choice-abort-string
		   #'(lambda ()
		       (signal-condition eh:*abort-object*)))))))
)

tv:
(defmacro w:maybe-ephemeral-cvv-menu
	  (variables &key
	   (permanent t)
	   (function nil)
	   (near-mode ''(:mouse))
	   (label "Choose Variable Values")
	   (width nil)
	   (extra-width 10.)
	   (height nil)
	   (margin-choices nil)
	   (superior nil)
	   (reverse-video-p nil)
	   (value-tab t)
	   (force-permanent nil)
	   (selected-io nil)
	   (foreground-color *default-menu-foreground*)
	   (background-color *default-menu-background*)
	   (label-color      *default-menu-label-foreground*)
	   (label-background *default-menu-label-background*)
	  )
"Just like choose-variable-values, only has a :Permanent arg.  If this is true
 then it organises things so that the cvv menu is only consed once.
"
  (if permanent
     `(let ((window-location ',(prog1 (gensym "CVV-WINDOW-" t) (gensym "G")))
	    (the-superior ,superior)
	    (near-mode ,near-mode)
	    (margin-choices ,margin-choices)
	    (old-allocate #'allocate-resource)
	    (old-deallocate #'deallocate-resource)
	   )
	   (if (boundp window-location)
	       (let ((osw selected-window))
		    (just-call-window window-location the-superior near-mode
				      margin-choices osw
		    )
	       )
	       (letf ((#'allocate-resource
		       #'(lambda (.name. &rest args)
			   (if (equal .name.
				   'tv:temporary-choose-variable-values-window)
			       (progn (setf (symbol-value window-location)
					    (make-window
					      'temporary-choose-variable-values-window
					      :superior
					      (or (first args)
						  tv:default-screen)
					      :edges-from
					      (list
						(sheet-inside-left
						  default-screen)
						(sheet-inside-top
						  default-screen)
						(sheet-inside-right
						  default-screen)
						(sheet-inside-bottom
						  default-screen))
					      :foreground-color
					      *default-menu-foreground*
					      :background-color
					      *default-menu-background*))
				      (symbol-value window-location))
			       (apply old-allocate .name. args))))
		      (#'deallocate-resource
		       #'(lambda (.name. &rest args)
			   (if (equal .name.
				   'tv:temporary-choose-variable-values-window)
			       nil
			       (apply old-deallocate .name. args))))
		     )
		     (choose-variable-values
		       ,variables
		       :function ,function
		       :label ,label
		       :width ,width
		       :superior the-superior
		       :near-mode ,near-mode
		       :margin-choices ,margin-choices
		       :extra-width ,extra-width
		       :height ,height
		       :reverse-video-p ,reverse-video-p
		       :value-tab ,value-tab
		       :force-permanent t;,force-permanent
		       :selected-io ,selected-io
		       :foreground-color ,foreground-color
		       :background-color ,background-color
		       :label-color ,label-color
		       :label-background ,label-background
		     )
	       )
	   )
      )
     `(choose-variable-values
	,variables
	:function ,function
	:label ,label
	:width ,width
	:superior ,superior
	:near-mode ,near-mode
	:margin-choices ,margin-choices
	:extra-width ,extra-width
	:height ,height
	:reverse-video-p ,reverse-video-p
	:value-tab ,value-tab
	:force-permanent ,force-permanent
	:selected-io ,selected-io
	:foreground-color ,foreground-color
	:background-color ,background-color
	:label-color ,label-color
	:label-background ,label-background
      )
  )
)

w:
(defun Process-Variable-Values-Items (an-item)
"This function is called by the choose variable values macros.  It is passed
 an item that the user wants to go into the menu.  The item is one of two
 things.  Either it is a list which has the structure (expression .rest), where
 the expression denotes the initial value/location of the initial value for the
 menu and the rest has an optional string, a keyword and optional arguments. 
 These are defined in the windows manual for choose variable values menus.  The
 other option is for the item to be a string.  This causes a separator to be
 produced in the menu.  This function returns a list, which has six elements
 and can be of two forms.  If the item that this function is passed is not a
 list ie. it is a string then
 (:Throw-Away :Throw-Away :Throw-Away :Throw-Away item :Throw-Away) is
 returned.  This causes the calling macro to throw everything away except the
 string.  If the item is a list then the six items that are returned are as
 follows:-  The first and second are generated symbols.  These will be declared
 special in the macro that calls this function so that Choose-variable-values
 can change its value and so that a special variable holds onto the initial
 value so that the quit option can be Evaled correctly.  Why the code in this
 choice box has to be interpretted I do not know but it's ridiculous in my
 opinion.  The third and fourth are lists denoting Setfs to the generated
 symbols of the initial value passed on by the user.  This will be displayed
 as the initial value by the menu.  The fourth is used as a reinitialisation
 clause in the quit option.  The Fifth is a list that actually goes into the
 argument list of choose variable values.  It specifies the generated symbol as
 the destination for the value returned by the user.  The Sixth value is a
 list denoting a Setf, which reassigns the value returned by the menu to the
 initial expression provided by the user.  This is only used in the side effect
 causing cases such as Assign-Using-Menu.
"
    (if (Consp an-item)
	(let ((Temporary-name-1 (Gensym))
	      (Temporary-name-2 (Gensym))
	     )
	     (List Temporary-name-1
		   Temporary-name-2
	           (List 'Setf Temporary-name-2 (First an-item))
	           (List 'Setf Temporary-name-1 Temporary-name-2)
	           (Cons 'List
			 (Cons (List 'Quote Temporary-name-1)
			       (if (Stringp (Second an-item))
			           (Cons (Second an-item)
				         (Rest (Rest an-item))
			           )			           
			           (Rest an-item)
			       )
			 )
		   )
	           (List 'Setf (First an-item) Temporary-name-1)
	     )
	)
	(List :Throw-Away :Throw-Away :Throw-Away
	      :Throw-Away an-item     :Throw-Away
	)
    )
)

w:
(defun defaultise-choose-variable-values-keywords (keywords)
"Gives a useful set of defaults for the CVV keywords."
  (let ((selected-io-to-add (if (member :Selected-IO keywords)
				nil
				#+TI '(:Selected-io nil)
				#+Symbolics nil
			    )
	)
	(superior-to-add (if (member :Superior keywords)
			     nil
			     #+TI '(:Superior tv:main-screen)
			     #+Symbolics nil
			 )
	)
       )
       (append selected-io-to-add superior-to-add keywords)
  )
)


w:
(defmacro tv:Assign-using-Menu (Items &Rest Keywords)
"This is a macro that parcels up a call to Choose-Variable-Values so that the
 user does not have to worry about defining any Special symbols to hold the
 values used by the menu.  It takes a menu specification like
 tv:choose-variable-values ie. a list of items &rest option keywords.  Calling
 this construct has the side effect of assigning the chosen values back to the
 items that as the specifications for the initial values, ie. the heads of the
 items within the item list.  The item list should not be quoted. This is done
 by mapping the user's arguments into the following code :-
    (Assign-using-Menu ((Item-one \"Item One\" :Expression)
			'A separator'
			(Item-two \"Item Two\" :String)
		       )
		       :Label \"A Name\"
    )

==>

   (Funcall #'(Lambda ()
		(Declare (Special #Genedsym1 #Genedsym1-2
				  #Genedsym2 #Genedsym2-2
			 )
		)
	        (Setf #Genedsym1-2 Item-one)
	        (Setf #Genedsym1 #Genedsym1-2)
	        (Setf #Genedsym2-2 Item-two)
	        (Setf #Genedsym2 #Genedsym2-2)
		(maybe-ephemeral-cvv-menu
		    (List (List '#Genedsym1 \"Item One\" :Expression)
			  'A separator'
			  (List '#Genedsym2 \"Item Two\" :String)
		    )
		    :Margin-Choices
			'((\"Abort [‘]\"
			   '(Progn (Setf #Genedsym1 #Genedsym1-2)
				   (Setf #Genedsym2 #Genedsym2-2)
			    )
			  )
                          \"Do it [”]\"
			 )			
		    :Label \"A Name\"
		)
	        (Setf Item-one #Genedsym1)
	        (Setf Item-two #Genedsym2)
	    )
    )
"
  (let ((Processed-Items (Mapcar #'Process-Variable-Values-Items Items)))
     `(Funcall ;; Call the automatically generated closure.
	#'(Lambda() ;; Define a closure in which to put the special variables
	 (Declare (Special ;; Construct a special declaration for the
			   ;; generated symbols.
		     ,@(Remove :Throw-Away ;; Throw away values for separators
				(Mapcar #'(Lambda (an-item) (First an-item))
				        Processed-Items
				)
		       )
		     ,@(Remove :Throw-Away ;; Throw away values for separators
				(Mapcar #'(Lambda (an-item) (Second an-item))
				        Processed-Items
				)
		       )
		  )
	 )
	 ;; Construct a set of initialisation Setfs
	 ,@(Remove :Throw-Away ;; Throw away values for separators
		  (Mapcar #'(Lambda (an-item) (Third  an-item)) Processed-Items)
	   )
	 ,@(Remove :Throw-Away ;; Throw away values for separators
		  (Mapcar #'(Lambda (an-item) (Fourth an-item)) Processed-Items)
	   )
	 ;; Get the user to choose from the menu.
	 (let ((result
		(condition-case nil
		 (Catch :Abort-Menu
		   (maybe-ephemeral-cvv-menu
		    ,(Cons 'List
			   (Mapcar #'(Lambda (an-item) (Fifth an-item))
				   Processed-Items
			   )
		     )
		    :Margin-Choices
			(List (List "Abort [‘]"
				    '(progn
				       ;; Reset the values of the #1 symbols.
					,@(Remove :Throw-Away
						(Mapcar #'(Lambda (an-item)
								(Fourth an-item)
							)
							Processed-Items
						)
					   )
					   (throw :Abort-Menu :Abort-Menu)
				    )
			      )
			      "Do it [”]"
			)
		    ,@(defaultise-choose-variable-values-keywords Keywords)
		   )
		 )
		 (sys:abort :Abort-Menu)
		)
	       )
	      )
	      ;; Construct a set of terminating Setfs
	      ,@(Remove :Throw-Away ;; Throw away values for separators
			(Mapcar #'(Lambda (an-item) (Sixth an-item))
				Processed-Items
		        )
	        )
	      result
	 )
        )
      )
  )
)

(export 'tv:Assign-using-Menu 'tv)

w:
(defmacro tv:Values-using-Menu (Items &Rest Keywords)
"This is a macro that parcels up a call to Choose-Variable-Values so that the
 user does not have to worry about defining any Special symbols to hold the
 values used by the menu.  It takes a menu specification like
 tv:choose-variable-values ie. a list of items &rest option keywords.  Calling
 this construct causes a value to be returned, which is a set of multiple
 values in the same order as the assignable items, ie. non-separators in the
 item list.  The item list should not be quoted. This is done by mapping the
 user's arguments into the following code :-
    (Values-using-Menu ((Item-one \"Item One\" :Expression)
			'A separator'
			(Item-two \"Item Two\" :String)
		       )
		       :Label \"A Name\"
    )

==>

   (Funcall #'(Lambda ()
		(Declare (Special #Genedsym1 #Genedsym1-2
				  #Genedsym2 #Genedsym2-2
			 )
		)
	        (Setf #Genedsym1-2 Item-one)
	        (Setf #Genedsym1 #Genedsym1-2)
	        (Setf #Genedsym2-2 Item-two)
	        (Setf #Genedsym2 #Genedsym2-2)
		(maybe-ephemeral-cvv-menu
		    (List (List '#Genedsym1 \"Item One\" :Expression)
			  'A separator'
			  (List '#Genedsym2 \"Item Two\" :String)
		    )
		    :Margin-Choices
			'((\"Abort [‘]\"
			   '(Progn (Setf #Genedsym1 #Genedsym1-2)
				   (Setf #Genedsym2 #Genedsym2-2)
			    )
			  )
                          \"Do it [”]\"
			 )			
		    :Label \"A Name\"
		)
	        (Values #Genedsym1 #Genedsym2)
	    )
    )
"
  (let ((Processed-Items (Mapcar #'Process-Variable-Values-Items Items)))
     `(Funcall ;; Call the automatically generated closure.
	#'(Lambda() ;; Define a closure in which to put the special variables
	 (Declare (Special ;; Construct a special declaration for the
			   ;; generated symbols.
		     ,@(Remove :Throw-Away ;; Throw away values for separators
				(Mapcar #'(Lambda (an-item) (First an-item))
				        Processed-Items
				)
		       )
		     ,@(Remove :Throw-Away ;; Throw away values for separators
				(Mapcar #'(Lambda (an-item) (Second an-item))
				        Processed-Items
				)
		       )
		  )
	 )
	 ;; Construct a set of initialisation Setfs
	 ,@(Remove :Throw-Away ;; Throw away values for separators
		  (Mapcar #'(Lambda (an-item) (Third  an-item)) Processed-Items)
	   )
	 ,@(Remove :Throw-Away ;; Throw away values for separators
		  (Mapcar #'(Lambda (an-item) (Fourth an-item)) Processed-Items)
	   )
	 ;; Get the user to choose from the menu.
	 (condition-case nil
	   (Catch :Abort-Menu
	     (maybe-ephemeral-cvv-menu
	      ,(Cons 'List
		     (Mapcar #'(Lambda (an-item) (Fifth an-item))
			     Processed-Items
		     )
	      )
	      :Margin-Choices
		  (List (List "Abort [‘]"
			      '(Progn ;; Reset the values of the #1 symbols.
				  ,@(Remove :Throw-Away
					  (Mapcar #'(Lambda (an-item)
							  (Fourth an-item)
						  )
						  Processed-Items
					  )
				     )
				     (Throw :Abort-Menu :abort-menu)
			      )
			)
			"Do it [”]"
		  )
	       ,@(defaultise-choose-variable-values-keywords Keywords)
	     )
	   )
	   (sys:abort :Abort-Menu)
	 )
	 ;; Return the values generated by the menu as multiple values.
	 (Values ,@(Remove :Throw-Away ;; Throw away values for separators
			   ;; This is the same as the list of specials.
			   (Mapcar #'(Lambda (an-item) (First an-item))
			     	   Processed-Items
			   )
		   )
	 )
        )
      )
  )
)

(export 'tv:Values-using-Menu 'tv)

;-------------------------------------------------------------------------------

(defun install-zmacs-commmand (command)
"Installs a zmacs command."
  (zwei:set-comtab zwei:*standard-comtab* command
		   (zwei:make-command-alist (rest command))
  )
)

(defun fs:cons-new (x list &key (test #'eql))
  (if (member x list :test test)
      list
      (cons x list)))

(defmacro tv:defperspective (&rest ignore))

(defun sys:try-to-compile-flavor-methods (&rest ignore))

(defun boundp-in-instance (instance variable)
  "True iff VARIABLE is bound in the INSTANCE."
  (sys:location-boundp (sys:locate-in-instance instance variable))
)
(export 'boundp-in-instance "TICL")

;-------------------------------------------------------------------------------

(defvar *already-messing-with-screen-arrays* nil
"A list of windows that the current process is hacking on to swap the
bit arrays for bacground drawing etc.
"
)

(defmacro tv:with-window-ops-on-bit-array
	  ((sheet &optional (save-bits-p t)) &body body)
"Execute BODY with SHEET pretending to be deexposed.   SHEET will be refreshed
afterward if it was exposed to begin with.  Returns the values of body.  If
Save-bits-p is true then the bits on the screen are saved to the bit array
before we go into the form.  This is a good idea unless you know that the
window is going to be completely redrawn.
Notes:  a) This macro doesn't seem to be much of a win on microExplorers.
        b) See also tv:without-window-ops-on-bit-array.
"
  `(let ((.sheet. ,sheet))
        (if (and nil (not (member .sheet. *Already-Messing-With-Screen-Arrays*))
	        (Tv:sheet-exposed-p .sheet.)
		(not (sys:mx-p))
	    )
	    (let ((.screen-array. (send .sheet. :Screen-Array))
		  (.bit-save-array. (send .sheet. :Bit-Array))
		  (.width. (tv:sheet-width .sheet.))
		  (.height. (tv:sheet-height .sheet.))
		  (*Already-Messing-With-Screen-Arrays*
		    (cons .sheet. *Already-Messing-With-Screen-Arrays*)
		  )
		 )
	         (check-type .bit-save-array. array)
		 (Prepare-sheet (.sheet.)
		   (if ,save-bits-p
		       (bitblt tv:alu-seta .width. .height. .screen-array.
			       0 0 .bit-save-array. 0 0
		       )
		   )
		   (tv:sheet-force-access (.sheet. nil)
		     (multiple-value-prog1
		      (letf (((symeval-in-instance .sheet. 'tv:screen-array)
			      .bit-save-array.
			     )
			     ((symeval-in-instance .sheet. 'tv:bit-array)
			      .screen-array.
			     )
			    )
			    ,@body
		      )
		      (send .sheet. :Refresh :use-saved-bits)
		     )
		   )
		 )
	    )
	    (progn ,@body)
	)
   )
)

(export 'tv:with-window-ops-on-bit-array 'tv)

(defmacro tv:without-window-ops-on-bit-array
	  ((sheet) &body body)
"Execute BODY with SHEET guaranteed not to be using
tv:with-window-ops-on-bit-array for its screen ops.
This is important if you are using tv:with-window-ops-on-bit-array
in a :refresh method (a generally good idea) because refresh is called
by set-edges and things get confused.  Thus if you do the above you should also
do (defwhopper (<my-window> :set-edges) (&rest args)
    (tv:without-window-ops-on-bit-array (self) (lexpr-continue-whopper args)))
"
 `(let ((*Already-Messing-With-Screen-Arrays*
	  (cons ,sheet *Already-Messing-With-Screen-Arrays*)
	)
       )
       ,@body
  )
)

(export 'tv:without-window-ops-on-bit-array 'tv)

;-------------------------------------------------------------------------------

(defun occurences (of in)
"Returns a count of the number of occurences of Of in the list In."
  (count of in :Test #'equal)
)

(defun Get-Least (of &optional (so-far '(1000000 1000000)))
"Given a list of pairs of the form ((e 0) (f 0) (d 1) (c 1) (b 2) (a 2)),
 returns the one that has the lowest number as its second element.
"
  (if of
     (if (< (second (first of)) (second so-far))
	 (Get-Least (rest of) (first of))
	 (Get-Least (rest of) so-far)
     )
     so-far
  )
)

;-------------------------------------------------------------------------------

format:
(defun tv:format-fat-string-stream (op &rest args)
  (case op
    (:tyo
     (or format-string (setq format-string (make-array 64. :type 'art-fat-string :fill-pointer 0.)))
      (vector-push-extend (first args) format-string))
    (:string-out
     (let ((string (first args))
	   (first (or (second args) 0.))
	   (last (third args))
	   new-length)
       (or format-string (setq format-string (make-array 64. :type 'art-fat-string :fill-pointer 0.)))
       (setq last (or last (length string)))
       (setq new-length (+ (array-leader format-string 0.) (- last first)))
       (and (< (array-total-size format-string) new-length)
	  (adjust-array format-string (+ (array-total-size format-string) new-length)))
       (copy-array-portion string first last format-string (array-leader format-string 0.)
			   new-length)
       (store-array-leader new-length format-string 0.)))
    (:read-cursorpos
     (let ((mode (or (first args) :character))
	   pos)
       (or format-string (setq format-string (make-array 64. :type 'art-fat-string :fill-pointer 0.)))
       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))
       (setq pos
	     (position #\NEWLINE (the string (string format-string)) :from-end t :test
		       #'char-equal))
       (values (- (length format-string) (if pos
					   (+ pos 1.)
					   0.)) 0.)))
    (:increment-cursorpos
     (let ((dx (first args))
	   (dy (second args))
	   (mode (or (third args) :character))
	   newlen)
       (or format-string (setq format-string (make-array 64. :type 'art-fat-string :fill-pointer 0.)))
       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))
       (or (and (zerop dy) (not (minusp dx))) (ferror () "Cannot do this :INCREMENT-CURSORPOS"))
       (setq newlen (+ (length format-string) dx))
       (and (< (array-total-size format-string) newlen)
	  (adjust-array format-string (+ (array-total-size format-string) newlen)))
       (do ((i (length format-string) (1+ i)))
	   ((>= i newlen))
	 (setf (aref format-string i) #\SPACE))
       (store-array-leader newlen format-string 0.)))
    (:set-cursorpos
     (let ((x (first args))
	   (y (second args))
	   (mode (or (third args) :character))
	   pos
	   delta
	   newlen)
       (or format-string (setq format-string (make-array 64. :type 'art-fat-string :fill-pointer 0.)))
       (or (eq mode :character) (ferror () "String cannot have :PIXEL"))
       (setq pos (string-reverse-search-set '(#\NEWLINE #\LINEFEED #\PAGE) format-string)
	     delta (- x (- (length format-string) (if pos
						    (+ pos 1.)
						    0.))))
       (or (and (zerop y) (plusp delta)) (ferror () "Cannot do this :SET-CURSORPOS"))
       (setq newlen (+ (length format-string) delta))
       (and (< (array-total-size format-string) newlen)
	  (adjust-array format-string (+ (array-total-size format-string) newlen)))
       (do ((i (length format-string) (1+ i)))
	   ((>= i newlen))
	 (setf (aref format-string i) #\SPACE))
       (store-array-leader newlen format-string 0.)))
    (:untyo-mark (fill-pointer format-string))
    (:untyo (let ((mark (first args)))
	      (setf (fill-pointer format-string) mark)))
    (extract-string (prog1
		      format-string
		      (setq format-string ())))
    (:get-string format-string)
    (:fresh-line
     (when (not
       (or (null format-string) (zerop (length format-string))
	  (= (aref format-string (1- (length format-string))) #\NEWLINE)))
       (vector-push-extend #\NEWLINE format-string)
       t))
    (:which-operations nil
     '(:tyo :string-out :read-cursorpos :increment-cursorpos :set-cursorpos :untyo-mark :untyo
       extract-string :fresh-line))
    (t (stream-default-handler 'format-string-stream op (car args) (cdr args)))))


(defun make-fat-string-output-stream (&optional string start-index extra-arg)
  (if (stringp start-index)
    (let ((string start-index)
	  (start-index extra-arg))
      (let-closed
       ((format-string
	  (or string
	      (make-array 64. :type 'art-fat-string :fill-pointer 0.))))
       (if start-index
	 (setf (fill-pointer format-string) start-index))
       'format-string-stream))
    (let-closed
      ((format-string
	 (or string
	     (make-array 64. :type 'art-fat-string :fill-pointer 0.))))
       (if start-index
	 (setf (fill-pointer format-string) start-index))
       'format-fat-string-stream)))

(defmacro with-output-to-fat-string
	  ((stream string index) &body body &aux (string-symbol string))
  (multiple-value-bind (realbody decls)
      (parse-body body nil nil)
    (let ((doc (and  decls `((declare . ,(sys:flatten-declarations decls))))))
      (if index
	  `(let* (,@(and (not (symbolp string))
			 `((,(setf string-symbol (gensym))  ,string)))
		  (,stream
		   (make-fat-string-output-stream ,string-symbol ,index)))
	     ,@doc 
	     (unwind-protect
		     (progn
		       ,@realbody)
		   (setf ,index (length ,string-symbol))))
	      `(let ((,stream (make-fat-string-output-stream
				,@(if string `(,string)))))
		 ,@doc
		 ,@realbody
		 ,@(if (null string )
		       `((get-output-stream-string ,stream))))))))


;;;TI Code:
sys:
(defun sys:make-string-input-stream (string &optional (start 0) end)
  "Return a stream from which one can read the characters of STRING, or some substring of it.
START and END are indices specifying a substring of STRING;
they default to 0 and NIL (NIL for END means the end of STRING)."
  ;;RDA: jpr seems to have added the (IF (TYPEP STRING 'ARRAY) STRING part
  (setq string (if (typep string 'array) string (string string)))
  (let-closed ((*ioch start) (*ioend (or end (length string))) (*iolst string))
     'read-from-string-stream))

;-------------------------------------------------------------------------------


(defun assoc-setf (item alist assoc-options newval)
  "If (ASSOC ITEM ALIST) finds an entry, set CDR of it to (CDR NEWVAL), else
   add (CONS ITEM (CDR NEWVAL)) to the end of ALIST.  Returns the (possibly
   new) entry.  Signals an error if ALIST isn't a list or if (NEQ (CAR NEWVAL)
   ITEM)."
   (check-arg alist consp "a list")
   (unless (eq (car newval) item)
     (error "Attempt to make ASSOC of ~S return ~S" item newval))
   (let ((item (apply #'assoc item alist assoc-options)))
     (if item
	 (setf (rest item) (cdr newval))
	 (nconc alist (list (setf item (cons item (cdr newval)))))
	 )
     item
     )
  )

(defsetf assoc (item alist &rest options) (newval)
  `(assoc-setf ,item ,alist (list ,@options) ,newval)
  )


(defmacro ticl:with-standard-io-environment (&body body)
 `(let ((*package* (find-package 'user))
        (*read-base* 10.)
	(*print-base* 10.)
	(*nopoint nil)
	(*readtable* sys:common-lisp-readtable)
	(*print-case* :Upcase)
	(*print-structure* t)
	(*print-circle* nil)
	(*print-level* nil)
	(*print-length* nil)
	(sys:*lisp-mode* :Common-Lisp)
	(sys:*reader-symbol-substitutions*
	  sys:*common-lisp-symbol-substitutions*
	)
       )
       ,@body
  )
)


(export 'ticl:with-standard-io-environment 'ticl)

;-------------------------------------------------------------------------------

(defun zwei:list-if-not (x)
  (if (listp x) x (list x))
)

;-------------------------------------------------------------------------------

fs:
(defsubst fs:fast-string-search (key string from to key-from key-to)
  (let ((key-len (- key-to key-from)))
    (cond
     ((= key-from key-to) (and (<= from to) from))
     (t (setq to (1+ (- to key-len)));Last position at which key may start +1
	(prog (ch1)
	      (cond
		((minusp to) (return ())))
	      (setq ch1 (aref key key-from))
	   loop
	      (or (setq from (%string-search-char ch1 string from to))
		  (return ()))
	      (and (%string-equal key key-from string from key-len)
		   (return from))
	      (setq from (1+ from))
	      (go loop))))))

fs:
(defun fs:Compare-String-Optimised
       (search-string case-sensitive-p line to start)
"
 Looks for Search-string in Line starting from Start, perhaps case sensitively.
 It returns the values; start index and end index of the pattern or nil, nil
 if it is not found.
"
  (let ((found-p
	  (let ((alphabetic-case-affects-string-comparison case-sensitive-p))
	       (fast-String-Search search-string line start to
				   0 (array-active-length search-string)
               )
          )
	)
       )
       (if found-p
	   (values found-p
		   (- (+ found-p (length (the string search-string))) 1)
	   )
	   (values nil nil)
       )
  )
)

fs:
(defun fs:Compare-String-Full
       (search-pattern case-sensitive-p line line-to
	line-start
       )
"
 Looks for Search-pattern in Line, starting at Line-start.  The search pattern
 can contain the wildcards.
"
  (if (listp search-pattern)
      (if search-pattern
	  (let ((search (first search-pattern)))
	       (case search
		 (:Multiple
		  (Compare-String-Full
		    (rest search-pattern) case-sensitive-p line
		    line-to line-start
		  )
		 )
		 (:Single
		  (multiple-value-bind (this-beginning this-end)
		    (Compare-String-Full
		      (rest search-pattern) case-sensitive-p line
		      line-to (+ 1 line-start)
		    )
		    (if (equal this-beginning (+ 2 line-start))
			(values line-start this-end)
			nil
		    )
		  )
		 )
		 (otherwise
		  (multiple-value-bind (this-beginning this-end)
		    (Compare-String-Optimised
		      search case-sensitive-p line line-to line-start
		    )
		    (if (not this-beginning)
			nil
			(if (rest search-pattern)
			    (multiple-value-bind (beginning end)
				(Compare-String-Full
				  (rest search-pattern) case-sensitive-p line
				  line-to this-end
				)
			      (if beginning
				  (values this-beginning end)
				  nil
			      )
			    )
			    (values this-beginning this-end)
			)
		    )
		  )
		 )
	       )
	  )
	  (values line-start line-start)
      )
      (Compare-String-Optimised
	search-pattern case-sensitive-p line line-to line-start
      )
  )
)

(defvar fs:*wildcard-char-quoting-character* #\\
"The character used to preceed a wildchar in a search
 string to make it a literal.
"
)

fs:
(defun fs:parse-search-string (string wildcards search-start this-string-start)
"Turns search strings into lists that specify the strings to search for.  For
example: the string \"Hello*Jim?what's up\" will translate into
  (\"Hello\" :Multiple \"Jim\" :single \"what's up\")
Wild chars can be quoted so that \"Hello\*Jim?what's up\" will translate
into (\"Hello*Jim\" :single \"what's up\").
"
  (let ((position (string-search-set wildcards string search-start)))
       (if position
	   (if (or (= position 0)
		   (and (> position 0)
		        (not (equal *wildcard-char-quoting-character*
				    (aref string (- position 1))
			     )
			)
		   )
	       )
	       (let ((part (subseq (the string string)
				   this-string-start position
			   )
		     )
		     (body
		       (cons (if (equal (first wildcards)
					(aref string position)
				 )
				 :Multiple
				 :Single
			     )
			     (Parse-Search-String
			       string wildcards (+ 1 position)
			       (+ 1 position)
			     )
		       )
		     )
		    )
		    (if (equal part "") body (cons part body))
	       )
	       (Parse-Search-String
		 (string-append
		   (subseq (the string string) this-string-start (- position 1))
		   (subseq (the string string) position)
		 )
		 wildcards (- (+ 1 position) this-string-start) 0
	       )
	   )
	   (if (equal this-string-start 0)
	       string
	       (let ((part (subseq (the string string) this-string-start)))
		    (if (equal part "")
			nil
			(list (subseq (the string string) this-string-start))
		    )
	       )
	   )
       )
  )
)


;-------------------------------------------------------------------------------

(defun rhb-p (&rest ignore))
(defun rhb-string (&rest ignore))