(defpackage :software-evolution-library/view

(:nicknames :sel/view)

(:use

:gt/full

:diff

:cl-interpol

:software-evolution-library

:software-evolution-library/terminal

:software-evolution-library/utility/debug)

(:shadow :diff)

(:shadowing-import-from :arrow-macros :-<>> :-<> :<>) ; FIXME: Remove.

(:export :*view-stream*

:*view-length*

:*view-delay*

:*view-running*

:*view-application-name*

:*view-application-version*

:*view-run-name*

:*view-mutation-header-p*

:*view-max-mutations*

:*view-max-note-lines*

:*view-max-best-lines*

:*view-max-best-offset*

:*view-functions*

:+golden-ratio+

:label-line-print

:best-print

;; View functions.

:timing-view-function

:population-label-view-function

:fitness-view-function

:genome-view-function

:mutation-label-view-function

:mutation-view-function

:best-label-view-function

:best-view-function

:notes-label-view-function

:notes-view-function

;; Interface functions.

:with-delayed-invocation

:view-truncate

:view-start

:view-controller-start))

(in-package :software-evolution-library/view)

(eval-when (:compile-toplevel :load-toplevel :execute)

(defreadtable view-readtable (:merge :curry-compose-reader-macros :interpol-syntax)))

(in-readtable view-readtable)

(defvar *view-length*

(handler-case (nth-value 2 (term-size))

(ioctl (e) (declare (ignore e)) 72))

"Dynamically bind to use modify.")

(defvar *view-delay* 2

"Seconds to wait between updating the view.")

(defvar *view-running* nil

"Set to nil to terminate the view thread.")

(defvar *view-application-name* "SEL"

"Name of the application using the view.")

(defvar *view-application-version* +software-evolution-library-version+

"Version string of the application using the view.")

(defvar *view-run-name* nil

"Set the name of the current run.

For example a description of the evolution target.")

(defvar *view-mutation-header-p* t

"Show headers of mutation stats.")

(defvar *view-max-mutations* 0

"Maximum number of mutations to show.")

(defvar *view-max-note-lines* 12

"Maximum number of lines of notes to show.")

(defvar *view-cached-note-lines* nil

"Holds cached note lines for continued display.")

(defvar *view-max-best-lines* 0

"Number of lines of the best candidate to show.")

(defvar *view-max-best-offset* 0

"Offset into the lines of the best candidate to show.")

(defun view-truncate (line &optional (less 2))

(if (length> line (- *view-length* less))

(subseq line 0 (- *view-length* less))

line))

(define-constant +golden-ratio+ 21/34)

(defun label-line-print (&key (value "") (values)

(color +color-RST+) (colors)

(balance (- 1 +golden-ratio+))

(filler-color +color-GRA+) (filler +b-h+)

(left +b-lt+) (right +b-rt+)

(inhibit-newline))

(let* ((values (or values (list value)))

(colors (or colors (list color)))

(remainder-length

(- *view-length* (+ 2 (reduce #'+ (mapcar #'length values)))))

(left-l (floor (* remainder-length balance)))

(right-l (ceiling (* remainder-length (- 1 balance)))))

(assert (and (>= left-l 0) (>= right-l 0))

(left-l right-l)

"Padding on one side is negative (~a,~a)" left-l right-l)

(unless inhibit-newline (format *view-stream* "~&"))

(with-color-printing filler-color

(with-line-printing

(format *view-stream* "~a" (concatenate 'string

(string left)

(make-string left-l

:initial-element filler)))))

(mapc (lambda (value color)

(with-color-printing color (format *view-stream* value)))

values colors)

(with-color-printing filler-color

(with-line-printing

(format *view-stream* "~a" (concatenate 'string

(make-string right-l

:initial-element filler)

(string right)))))))

(defun runtime-print ()

(if *start-time*

(label-line-print

:balance 0

:colors (list +color-GRA+ +color-RST+

+color-GRA+ +color-RST+

+color-GRA+ +color-RST+)

:values

(remove nil

(list

" runtime: "

(multiple-value-bind

(days remainder) (floor (/ (elapsed-time) 86400))

(multiple-value-bind

(hours remainder) (floor (/ (* remainder 86400) 3600))

(multiple-value-bind

(minutes remainder) (floor (/ (* remainder 3600) 60))

(format nil "~dd ~dh ~2,'0dm ~2,'0ds" days hours minutes

(floor (* remainder 60))))))

" evals: "

(format nil "~f" *fitness-evals*)

(when (and *fitness-evals* (cdadr *mutation-improvements*))

" last-improv: ")

(when (and *fitness-evals* (cdadr *mutation-improvements*))

(format nil "~d"

(- *fitness-evals*

(cdadr *mutation-improvements*))))))

:filler #\Space :left +b-v+ :right +b-v+)

(label-line-print

:balance 0

:value "No run started."

:color +color-GRA+

:filler #\Space :left +b-v+ :right +b-v+)))

(defun fitness-data-print (best med &optional union uniq)

(label-line-print

:balance 0

:colors (append

(list +color-PIN+ +color-GRA+ +color-RST+ +color-GRA+ +color-RST+)

(list +color-GRA+ +color-RST+ +color-GRA+ +color-RST+))

:values (append

(list

" fitness"

" best: " best

" med: " med)

(when (and uniq union)

(list

" union: " union

" uniq: " uniq)))

:filler #\Space :left +b-v+ :right +b-v+))

(defun genome-data-print (min med max)

(label-line-print

:balance 0

:colors (list +color-PIN+

+color-GRA+ +color-RST+

+color-GRA+ +color-RST+

+color-GRA+ +color-RST+)

:values (list " length" " min: " min " med: " med " max: " max)

:filler #\Space :left +b-v+ :right +b-v+))

(defun mutation-stats-print (stats)

(let ((longest (extremum (mapcar [#'length #'symbol-name #'car] stats) #'>))

(keys '(:better :same :worse :dead)))

(when *view-mutation-header-p*

(label-line-print

:balance 0

:colors (mapcar (constantly +color-PIN+) (append (list 1 2 3) keys))

:values (append (cons (format nil " ~V@a " longest "MUTATION")

(mapcar (lambda (key) (format nil " ~6@a" key)) keys))

(list " /" " total"))

:filler #\Space :left +b-v+ :right +b-v+))

(mapc (lambda (mut)

(label-line-print

:balance 0

:colors

(append (cons +color-GRA+

(mapcar (constantly +color-RST+) keys))

(list +color-GRA+ +color-RST+))

:values

(append (list (format nil " ~V@a:" longest (car mut)))

(mapcar (lambda (key)

(format nil " ~6d"

(or (aget key (cdr mut)) 0)))

keys)

(list " / "

(format nil "~d"

(reduce #'+ (mapcar #'cdr (cdr mut))))))

:filler #\Space :left +b-v+ :right +b-v+))

(append stats

(list

(cons :total

(mapcar (lambda (key)

(cons key

(nest (reduce #'+)

(remove nil)

(mapcar [{aget key} #'cdr]

stats))))

(list :better :dead :same :worse))))))))

(defun notes-print (lines)

(mapc (lambda (line)

(label-line-print :value line :color +color-GRA+ :balance 0

:filler #\Space :left +b-v+ :right +b-v+))

lines))

(defun best-print (lines)

(mapc (lambda (line)

(label-line-print :value line :color +color-RST+ :balance 0

:filler #\Space :left +b-v+ :right +b-v+))

lines))

(eval-when (:compile-toplevel :load-toplevel :execute)

(defun subtree-starting-with (token tree &key (test #'equalp))

(if (funcall test token (car tree)) tree

(car (remove nil (mapcar {subtree-starting-with token}

(remove-if-not #'listp tree)))))))

(eval-when (:compile-toplevel :load-toplevel :execute)

(defun replace-subtree-starting-with (token replace tree &key (test #'equalp))

(mapcar (lambda (subtree)

(if (and (listp subtree) (car subtree))

(if (funcall test token (car subtree))

replace

(replace-subtree-starting-with token replace subtree))

subtree))

tree)))

(defmacro with-delayed-invocation (spec &rest body)

"Take a form with a function marked as DELAYED.

(let* ((function (first spec))

(conditional (second spec))

(syms-and-args (mapcar (lambda (arg) (list (gensym) arg))

(cdr (subtree-starting-with function body)))))

(assert syms-and-args (function body)

"Couldn't find instance of ~a in ~a" function body)

(let ((body (replace-subtree-starting-with

function

`(let ,syms-and-args

(lambda () (,function ,@(mapcar #'car syms-and-args))))

`(progn ,@body))))

(if conditional

`(if ,conditional ,body (lambda ()))

body))))

(defun timing-view-function ()

(lambda ()

(label-line-print :value " timing " :color +color-CYA+

:balance (/ (- 1 +golden-ratio+) 2)

:left +b-lt+ :right +b-rt+)

(runtime-print)))

(defun population-label-view-function ()

(lambda ()

(when (and *population* (every #'fitness *population*))

(label-line-print :value " population " :color +color-CYA+

:balance (/ (- 1 +golden-ratio+) 2)

:left +b-vr+ :right +b-vl+))))

(defun filter-population-by-fitness-type (population

&key

(type (if (numberp

(fitness

(first population)))

:scalar

:vector)))

"Filter POPULATION so that all members have TYPE (:VECTOR or :SCALAR) fitness.

(remove-if-not (ecase type

(:scalar #'numberp)

(:vector #'vectorp))

population :key #'fitness))

(defun fitness-view-function ()

;; Fitness data information (pre-calculated).

(with-delayed-invocation (fitness-data-print

(and *population* (every #'fitness *population*)))

(let* ((vectorp (not (numberp (fitness (car *population*)))))

;; only include variants that have the right type (numeric or vector)

(fit-population (filter-population-by-fitness-type

*population*

:type (if vectorp :vector :scalar)))

(fits (mapcar (if vectorp

[{reduce #'+} #'fitness]

#'fitness)

fit-population)))

(fitness-data-print

(format nil "~6f" (extremum fits *fitness-predicate*))

(format nil "~6f" (median fits))

(when vectorp

(format nil "~6f"

(nest (reduce #'+)

(apply #'mapcar [{apply #'min} #'list])

(mapcar [{coerce _ 'list} #'fitness]

fit-population))))

(when vectorp

(format nil "~d"

(/ (length (remove-duplicates

(mapcar #'fitness fit-population)

:test #'equalp))

(length fit-population))))))))

(defun genome-view-function ()

;; Genomic data informaion (pre-calculated).

(with-delayed-invocation (genome-data-print *population*)

(let ((lengths

(without-compiler-notes

(mapcar [#'length #'lines] *population*))))

(genome-data-print (format nil "~d" (apply #'min lengths))

(format nil "~d" (median lengths))

(format nil "~d" (apply #'max lengths))))))

(defun mutation-label-view-function ()

(lambda ()

(when (and (> *view-max-mutations* 0)

(> (hash-table-count *mutation-stats*) 0))

(label-line-print :value " mutations " :color +color-CYA+

:balance (/ (- 1 +golden-ratio+) 2)

:left +b-vr+ :right +b-vl+))))

(defun mutation-view-function ()

(with-delayed-invocation

(mutation-stats-print

(and (> *view-max-mutations* 0)

(> (hash-table-count *mutation-stats*) 0)))

(mutation-stats-print

(take *view-max-mutations*

(sort (summarize-mutation-stats) #'>

:key (lambda (mut)

(/ (or (aget :better (cdr mut)) 0)

(reduce #'+ (mapcar

#'cdr (cdr mut))))))))))

(defun best-label-view-function ()

(lambda ()

(when (and (> *view-max-best-lines* 0)

*population*

(every #'fitness *population*))

(label-line-print :value " best " :color +color-CYA+

:balance (/ (- 1 +golden-ratio+) 2)

:left +b-vr+ :right +b-vl+))))

(defun best-view-function ()

(with-delayed-invocation (best-print (and (> *view-max-best-lines* 0)

*population*

(every #'fitness *population*)))

(best-print (-<>> (filter-population-by-fitness-type *population*)

(extremum <> #'fitness-better-p :key #'fitness)

(genome-string)

(split-sequence #\Newline)

(mapcar #'view-truncate)

((lambda (lines) ; Allow scrolling through the best lines.

(drop (max (min *view-max-best-offset*

(1- (- (length lines)

*view-max-best-lines*)))

0)

lines)))

(append <> (make-list *view-max-best-lines*

:initial-element ""))

(take *view-max-best-lines*)))))

(defun notes-label-view-function ()

(lambda ()

(when (> *view-max-note-lines* 0)

(label-line-print :value " notes " :color +color-CYA+

:balance (/ (- 1 +golden-ratio+) 2)

:left +b-vr+ :right +b-vl+))))

(defun notes-view-function ()

(with-delayed-invocation (notes-print (> *view-max-note-lines* 0))

(notes-print

(setf *view-cached-note-lines*

(-<>> *note-out*

(find-if #'string-output-stream-p)

(get-output-stream-string)

(split-sequence #\Newline <>

:remove-empty-subseqs t)

(mapcar

(lambda (line)

(multiple-value-bind (start end)

(scan "^;;\\d\\d\\d\\d.\\d\\d.\\d\\d." line)

(if start

(subseq line end)

line))))

(mapcar #'view-truncate)

(reverse)

(append <> *view-cached-note-lines*)

(take *view-max-note-lines*))))))

(defvar *view-functions*

'(timing-view-function

population-label-view-function

fitness-view-function

genome-view-function

mutation-label-view-function

mutation-view-function

best-label-view-function

best-view-function

notes-label-view-function

notes-view-function)

"List of the functions called to populate the view.

and returning of quickly-executing printing functions.")

(defun view-status ()

(clear-terminal)

(hide-cursor)

(label-line-print

:values (append (list (format nil " ~a " *view-application-name*)

*view-application-version*)

(when *view-run-name*

(list (format nil " (~a)" *view-run-name*))))

:colors (list +color-YEL+ +color-CYA+ +color-LGN+)

:balance 1/2

:inhibit-newline t

:filler #\Space :left #\Space :right #\Space)

;; Double-evaluate the view functions first to return the printing

;; functions, then to quickly call the printing functions.

(nest (mapcar #'funcall)

(mapcar #'funcall *view-functions*))

(label-line-print :left +b-lb+ :right +b-rb+)

(force-output *view-stream*))

(defun view-start ()

"Start a viewing thread regularly updating `view-status'.

(setf *view-running* t)

(unless

(or (zerop *view-max-note-lines*) ; If we want to show notes,

(some #'string-output-stream-p *note-out*)) ; and need string stream.

(push (make-string-output-stream) *note-out*))

(make-thread

(lambda ()

(let ((*view-stream* *standard-output*))

(iter

(while *view-running*)

(view-status)

(sleep *view-delay*))))

:name "view"))

(defun view-help ()

(clear-terminal)

(label-line-print :value "TODO: HELP" :left +b-lb+ :right +b-rb+))

(defun handle-user-input (command-char)

;; TODO: limits on changes to offset

;; TODO: horizontal scrolling

;; TODO: help on ?

;; TODO: signals for refresh, for more responsive commands

(case command-char

(#\k (decf *view-max-best-offset*))

(#\j (incf *view-max-best-offset*))

(#\u (decf *view-max-best-offset* *view-max-best-lines*))

((#\Space #\n #\d) (incf *view-max-best-offset* *view-max-best-lines*))

(#\g (setf *view-max-best-offset* 0))

(#\G (let ((best (extremum *population* #'fitness-better-p :key #'fitness)))

(setf *view-max-best-offset*

(max 0 (- (length (split-sequence #\Newline

(genome-string best)))

*view-max-best-lines*)))))

(#\? (view-help))

(otherwise (note 3 "Unknown command char ~S" command-char)))

;; Return nil on q or Q to terminate.

(not (or (equal command-char #\q)

(equal command-char #\Q))))

(defun view-controller-start ()

(make-terminal-raw)

(make-thread

(lambda ()

(iter (for command-char = (read-char))

(while (handle-user-input command-char)))

:name "view-controller")))