;;; -*- Mode:LISP; Package:LAMBDA; Readtable:ZL; Base:10; Lowercase:T; Fonts:(CPTFONTB) -*-
;;;
;;; (c) Copyright 1986 - Lisp Machine, Inc.
;;;

;;; Youcef. 01/06/86.
;;;
;;; This will provide an interface to the setup function.
;;;

(defstruct (line-for-memory
	      :NAMED-ARRAY
	     (:PRINT-FUNCTION (LAMBDA (OBJECT STREAM)
				(SYS:PRINTING-RANDOM-OBJECT (OBJECT STREAM :TYPE)
				  (FORMAT STREAM " address ~S @ ~A"
					  (memory-line-address object)
					  (memory-line-type OBJECT)))))
	     (:conc-name memory-line-)
	     (:alterant nil)
	     )
  (:type nil :documentation "OPC C-MEM A-MEM M-MEM ...")
  (:address 0 :documentation "the address we are looking at")
  (:contents nil :documentation "The contents at that address. could be numerical or symbolic")
  (:opc-number 0 :documentation "this would keep track of which opc we are currently looking at")
  (:bold-font nil :documentation "Lines that are expanded for opcs")
  )

(defresource memory-line-resource () :constructor (make-line-for-memory) :initial-copies 0)

(defflavor memory-window
	   ((list-of-lines nil)
	    (memory-type nil)
	    (last-location 0)
	    (list-of-summarized-opcs-if-opc-window nil)
	    )
	   (tv:function-text-scroll-window
	    tv:mouse-sensitive-text-scroll-window
	    tv:text-scroll-window
	    tv:borders-mixin
	    tv:top-label-mixin
	    tv:basic-scroll-bar
	    tv:flashy-scrolling-mixin
	    tv:margin-scroll-mixin
	    tv:margin-region-mixin
	    tv:margin-choice-mixin
	    tv:dont-select-with-mouse-mixin
	    tv:window)
  (:default-init-plist
    :label '(:string "Setup environment window" :centered :font fonts:metsi)
    :margin-choices '(("Down a page" nil down-one-page nil nil)
		      ("Up a page" nil up-one-page nil nil)
		      ("Top" nil top-of-buffer nil nil)
		      ("Bottom" nil bottom-of-buffer nil nil)
		      ("LAM" nil RETURN-TO-LAM nil nil)
		      ("Exit LAM" NIL Exit-LAM NIL NIL)
		      ("Memory" NIL Examine-memory NIL NIL))
    :flashy-scrolling-region '((20 0.30 0.70) (20 0.30 0.70))
    :margin-scroll-regions '((:top) (:bottom))
    :font-map (list fonts:cptfontb fonts:tr12
		    fonts:tr8 fonts:tr8b
		    fonts:tr10 fonts:tr10b
		    fonts:tr10i fonts:tr10bi
		    fonts:tr8i fonts:tr12b
		    fonts:tr12i fonts:tr12bi)
    :blinker-p t
    :blinker-deselected-visibility :off
    :blinker-flavor 'tv:rectangular-blinker
    :print-function 'output-memory-line)
  :gettable-instance-variables
  :settable-instance-variables
  :inittable-instance-variables)

;;;;;;
;;;;;;
;;;
;;;  Resource window for examining memories in the processor.
;;;
;;;;;;
;;;;;;

(defflavor temporary-memory-window () (memory-window))

(defwindow-resource temporary-memory-window ()
  :make-window (temporary-memory-window :height 500 :width 1000)
  :reusable-when :deactivated
  :initial-copies 1)

;;;;;;
;;;;;;
;;;
;;;  Method to get lines to be displayed or deleted from display window.
;;;
;;;;;;
;;;;;;


(defmethod (memory-window :delete-elements) (&optional (index 0) line)
  "Delete all lines up to line with item number index"
  (do ((index-of-item-to-flush index index))
      ((= (array-leader tv:items 0) index))
    (deallocate-resource 'memory-line-resource (setq line (funcall-self :ITEM-OF-NUMBER index)))
    (setq list-of-lines (delq line list-of-lines))
    (funcall-self :DELETE-ITEM index-of-item-to-flush))
  )

(defmethod (memory-window :add-line-to-be-displayed) (line)
  (push line list-of-lines)
  (funcall-self :APPEND-ITEM line)
  )

(defun display-opc-line (i &aux adr)
  (setq adr (+ (lam-lookup-name 'OPC) i))
  (lam-slash adr)
  )

;;; We suppose that the opcs are saved in array lam-saved-opcs
;;; we display 100 opc's each time.
;;;

(defvar *summarized-opcs-string* nil)

(defun get-list-of-summarized-opcs-number (&aux label line index indices)
  (setq *summarized-opcs-string*
	(with-output-to-string (*standard-output*)
	  (funcall (get 'summarize-opcs 'lam-colon-cmd) nil)))
  (with-input-from-string (stream *summarized-opcs-string*)
    ;; first get a line
    (do-forever
      (setq line (readline stream nil))
      (or line (return))
      (if (string-equal line "")
	  NIL
	;; read now from the line string the opc number.
	;; first read from line skips over "opc"
	(multiple-value (nil index) (read-from-string line))
	;; second read from line skips over label for example |0 ILLOP|
	(multiple-value (label index) (read-from-string line nil index))
	;; now we can get opc number
	(setq index (read-from-string (format nil "~A" label)))
	(if (numberp index)
	    (push index indices)
	  (setq index (format nil "~A" index))
	  (push (read-from-string (setq label (format nil "~A" index)) nil 0 (string-search "-" label))
		indices)))))
  indices
  )

(defvar *summarized-opcs-lines* nil)

(defun display-saved-opcs (&aux line string)
  (setq *memory-window*
	(dolist (window *list-of-temp-windows*)
	  (and (equal (funcall window :memory-type) 'OPC)
	       (return window))))
  (if *memory-window*
      (funcall *memory-window* :expose)
    (using-resource (*memory-window* temporary-memory-window *frame*)
      ;; just created a window to use for opc's.
      (multiple-value-bind (x y) (funcall *interaction-pane* :position)
	(funcall *memory-window* :set-position x y))
      (multiple-value-bind (w h) (funcall *interaction-pane* :size)
	(funcall *memory-window* :set-size w h))
      (push *memory-window* *list-of-temp-windows*)
      (setq *summarized-opcs-lines* (get-list-of-summarized-opcs-number))
      (funcall *memory-window* :set-label
	       (list :string "OPC's" :font fonts:metsi :centered))
      ;; if it is the first time then put in last-location slot of window 101.
      ;; which will be the next location to load if user wants to display more.
      (funcall *memory-window* :set-last-location 101.)
      (funcall *memory-window* :set-memory-type 'OPC)
      ;; now go and construct lines to be displayed in window
      (dotimes (i 101)
	(setq string (with-output-to-string (*standard-output*)
		       (display-opc-line i)))
	  ;; string has the string that has to be output as line in this window.
	(setq line (allocate-resource 'memory-line-resource))
	(setf (memory-line-type line) 'OPC)
	(setf (memory-line-opc-number line) i)
	(setf (memory-line-contents line) string)
	(setf (memory-line-bold-font line)
	      (if (member i *summarized-opcs-lines*)
		  ;(funcall *memory-window* :set-list-of-summarized-opcs-if-opc-window))
		  T NIL))
	(funcall *memory-window* :add-line-to-be-displayed line)
	)
      (funcall *memory-window* :expose)
      )
    )
  )

(defun get-more-of-opcs (*memory-window*)
  (pkg-bind "LAMBDA"
    (let ((next-opc (funcall *memory-window* :last-location))
	  next-available-opc line string)
      (if (> next-opc 4095.)			;largest hram location.
	  ;; no more are available just return.
	  NIL
	(setq next-available-opc (min (+ next-opc 100) #o100000))
	(dotimes (i (min 101 (- next-available-opc next-opc)))
	  (setq string (with-output-to-string (*standard-output*)
			 (display-opc-line (+ next-opc i))))
	  ;; string has the string that has to be output as line in this window.
	  (setq line (allocate-resource 'memory-line-resource))
	  (setf (memory-line-type line) 'OPC)
	  (setf (memory-line-opc-number line) (+ next-opc i))
	  (setf (memory-line-contents line) string)
	  (setf (memory-line-bold-font line)
		(if (member i *summarized-opcs-lines*)
		    T NIL))
	  (funcall *memory-window* :add-line-to-be-displayed line)))
      (funcall *memory-window* :set-last-location next-available-opc)))
  )

;;; some more functions for displaying the different memories.

(defun display-memory-line (lowest-address offset)
  (lam-slash (+ lowest-address offset))
  )

(defun display-memories (memory &aux memory-type lowest-address string line)
  ;; memory is either AMEM MMEM CMEM MID...
  ;; find if there is a window in *list-of-temp-windowS* which is for type memory.
  (pkg-bind "LAMBDA"
    (setq *memory-window*
	  (dolist (window *list-of-temp-windows*)
	    (and (equal (funcall window :memory-type) memory)
		 (return window))))
    (if *memory-window*
	(funcall *memory-window* :expose)
      ;; No window for this type of memory so create one and get first one hundred locations
      (setq memory-type (selectq memory
			  (MMEM 'M)
			  (AMEM 'A)
			  (CMEM 'C)
			  (MID 'MID)
			  (DMEM 'D)
			  (L1MEM '|1|)
			  (L2MEM '2P)
			  (US 'U)
			  (2CMEM '2C)
			  (FD 'FD)
			  (FS 'FS)
			  ))
      (SETQ lowest-address (eval (get memory-type 'lam-lowest-adr)))
      (using-resource (*memory-window* temporary-memory-window *frame*)
	;; just created a window to use for memory type
	(multiple-value-bind (x y) (funcall *interaction-pane* :position)
	  (funcall *memory-window* :set-position x y))
	(multiple-value-bind (w h) (funcall *interaction-pane* :size)
	  (funcall *memory-window* :set-size w h))
	(push *memory-window* *list-of-temp-windows*)
	(funcall *memory-window* :set-label
		 (list :string
		       (format nil "~A MEMORY"
			       (selectq memory
				 (MMEM 'M)
				 (AMEM 'A)
				 (CMEM 'CONTROL)
				 (MID 'MID)
				 (DMEM 'DISPATCH)
				 (L1MEM 'LEVEL-1-MAP)
				 (L2MEM 'LEVEL-2P-MAP)
				 (US 'MICRO-STACK)
				 (2CMEM 'LEVEL-2CONTROL-MAP)
				 (FD 'Functional-Destinations)
				 (FS 'Functional-Sources)
				 ))
		       :font fonts:metsi :centered))
	;; if it is the first time then put in last-location slot of window 101.
	;; which will be the next location to load if user wants to display more.
	(funcall *memory-window* :set-last-location (if (equal memory-type 'M) 64. 101.))
	(funcall *memory-window* :set-memory-type memory)
	;; now go and construct lines to be displayed in window
	(dotimes (i (if (equal memory-type 'M) 64. 101.))
	  (setq string (with-output-to-string (*standard-output*)
			 (display-memory-line lowest-address i)))
	  ;; string has the string that has to be output as line in this window.
	  (setq line (allocate-resource 'memory-line-resource))
	  (setf (memory-line-type line) memory-type)
	  (setf (memory-line-address line) i)
	  (setf (memory-line-contents line) string)
	  (funcall *memory-window* :add-line-to-be-displayed line)
	  )
	(funcall *memory-window* :expose)
	)))
    )

(defun get-more-of-memory (window &aux next-offset
			   memory-type lowest-address
			   last-offset next-available-offset
			   string line)
  (pkg-bind "LAMBDA"
    (if (equal (setq memory-type (funcall window :memory-type)) 'MMEM)
	NIL
      (setq last-offset (funcall window :last-location))
      (setq lowest-address
	    (eval (get (selectq memory-type
			 (CMEM (setq last-offset #o7777) 'C)
			 (MID (setq last-offset #o10000) 'MID)
			 (AMEM (setq last-offset #o2000) 'A)
			 (US (setq last-offset #o400) 'U)
			 (L1MEM (setq last-offset #o7777) '|1|)
			 (L2MEM (setq last-offset #o7777) '2P)
			 (2CMEM (setq last-offset #o7777) '2C)
			 (DMEM (setq last-offset #o2000) 'D)
			 (FS  'FS)
			 (FD 'FD)
			 )
		       'lam-lowest-adr)))
      
      (if (> (setq next-offset (funcall window :last-location)) last-offset)
	  ;; no more are available just return.
	  NIL
	(setq next-available-offset (min (+ next-offset 100.) (1+ last-offset)))
	(dotimes (i (min 101 (- next-available-offset next-offset)))
	  (setq string (with-output-to-string (*standard-output*)
			 (display-memory-line lowest-address i)))
	  ;; string has the string that has to be output as line in this window.
	  (setq line (allocate-resource 'memory-line-resource))
	  (setf (memory-line-type line) memory-type)
	  (setf (memory-line-address line) (+ next-offset i))
	  (setf (memory-line-contents line) string)
	  (funcall window :add-line-to-be-displayed line))
	(funcall window :set-last-location next-available-offset))))
  )

;;;;;;
;;;;;;
;;;
;;;  Output function for this resource window.
;;;
;;;;;;
;;;;;;


(defun output-memory-line (line arg window &rest ignore)
  "line is a structure for memory line. It has an address which is printed
in octal followed by @ and memory keyword (CMEM, A, M....) and a slash /
and then the contents of the memory. If OPC's are being look at, we then
assume that the lines (or some of them have been generated by summerise-opcs
and lines are mouse sensitive. Left click on the line will expand it to the
OPC's between calls. Middle click on the line will retract the information
if it is present."
  arg
  (let ((type (memory-line-type line))
	(address (memory-line-address line))
	(contents (memory-line-contents line)))
    (selectq type
      (OPC
       ;; Special treatement.
       (funcall window :set-current-font fonts:tr8b)
       (format window "OPC~O//~5T" (memory-line-opc-number line))
       (if (memory-line-bold-font line)
	   (funcall window :set-current-font fonts:tr8b)
	 (funcall window :set-current-font fonts:tr8))
       (funcall window :item1 contents line #'princ)
       )
      (otherwise
       (funcall window :Set-current-font fonts:tr10b)
       (format window "~O@~A//~5T" address type)
       (funcall window :Set-current-font fonts:tr10)
       (format window "~A" CONTENTS))
      )
    )
  )

;;;;;;
;;;;;;
;;;
;;;  Fuction for the choice process.
;;;
;;;;;;
;;;;;;

(defvar *memory-window* nil)

(defvar *list-of-temp-windows* NIL)

(defun EXIT-LAM (&rest ignore &aux window)
  (DECLARE (:SELF-FLAVOR memory-window))
  (dotimes (i (length *list-of-temp-windows*))
    (setq window (pop *list-of-temp-windows*))
    (funcall window :deactivate)
    (funcall window :delete-elements)
    )
  (funcall *interaction-pane* :select)
  (force-input #\altmode)
  (process-data-path)
  )

(defun RETURN-TO-LAM (&rest ignore)
  (DECLARE (:SELF-FLAVOR memory-window))
  (funcall *interaction-pane* :select)
  )

(defun top-of-buffer (&rest ignore)
  (DECLARE (:SELF-FLAVOR memory-window))
  (funcall-self :scroll-to 0 nil)
  )

(defun bottom-of-buffer (&rest ignore)
  (DECLARE (:SELF-FLAVOR memory-window))
  (funcall-self :scroll-to
		(max 0 (- (funcall-self :number-of-item (funcall-self :last-item))
			  (// (tv:sheet-inside-height self) (tv:sheet-line-height self))
			  -1))
		nil)
  )

(defun up-one-page (&rest ignore)
  ;; we go back a page if we can. otherwise we go to the top
  (DECLARE (:SELF-FLAVOR memory-window))
  (let ((top-item-number (funcall-self :top-item))
	(size-in-lines (// (tv:sheet-inside-height self) (tv:sheet-line-height self))))
    (if (> top-item-number size-in-lines)
	(funcall-self :scroll-to (- top-item-number size-in-lines) nil)
      (or (zerop top-item-number) (funcall-self :scroll-to 0 nil))))
  )

(defun down-one-page (&rest ignore)
  (DECLARE (:SELF-FLAVOR memory-window))
  (let ((last-item-number (funcall-self :number-of-item (funcall-self :last-item)))
	(top-item-number (funcall-self :top-item))
	(size-in-lines (// (tv:sheet-inside-height self) (tv:sheet-line-height self))))
    ;; if last-item-number is already in window then forget it.
    ;; otherwise scroll one more page
    (if (> (- last-item-number top-item-number)
	    size-in-lines)
	 ;; it is ok we still have things below which are not on the screen.
	 (funcall-self :scroll-to (min (- last-item-number size-in-lines -1)
				       (+ top-item-number size-in-lines))
		       nil)
      ;; otherwise go get some more if we can.
      (selectq (funcall-self :memory-type)
	(opc (get-more-of-opcs self))
	(otherwise (get-more-of-memory self))
	)
      (and
	(>
	  (- (setq last-item-number
		   (funcall-self :number-of-item
				 (funcall-self :last-item)))
	     top-item-number)
	      size-in-lines)
	   ;; it is ok we still have things below which are not on the screen.
	   (funcall-self :scroll-to (min (- last-item-number size-in-lines -1)
					 (+ top-item-number size-in-lines))
			 nil))))
  )

(defun EXAMINE-MEMORY (&rest ignore)
  (DECLARE (:SELF-FLAVOR memory-window))
  (let ((memory-to-examine
	  (tv:menu-choose
	    '(("Control memory" :value CMEM :font fonts:tr10b :documentation "examine Control memory")
	      ("A scratch memory" :value AMEM :font fonts:tr10b :documentation "examine A-mem memory")
	      ("M scratch memory" :value MMEM :font fonts:tr10b :documentation "examine M-mem memory")
	      ("Level 1 map memory" :value L1MEM :font fonts:tr10b :documentation "examine Level 1 map memory")
	      ("Level 2 map memory" :value L2MEM :font fonts:tr10b :documentation "examine Level 2 map memory")
	      ("Macro Instruction memory" :value MID :font fonts:tr10b :documentation "examine Macro Instruction memory")
	      ("OPC's" :value OPC :font fonts:tr10b :documentation "examine History Ram")
	      ("Control memory" :value CMEM :font fonts:tr10b :documentation "examine Control memory"))
	    '(:string "Choose a memory type" :font fonts:tr12bi :centered)
	    '(:mouse) nil self)))
    (when memory-to-examine
      (funcall *interaction-pane* :select)
      (if (equal memory-to-examine 'OPC)
	  (display-saved-opcs)
	(display-memories memory-to-examine))))
  )