this is my config

#.(declaim (optimize (safety 3) (debug 3) (space 0) (speed 0) (compilation-speed 0) (inhibit-warnings 0)))

(load "/home/oleo/common-lisp/source/asdf/build/asdf.lisp")

#- :quicklisp
(defun init-quick ()
  (let ((*read-eval* t))
    (let ((quicklisp-init (merge-pathnames "/home/oleo/quicklisp/setup.lisp"
                (user-homedir-pathname))))
      (if (probe-file quicklisp-init)
    (load quicklisp-init)
    (load "/home/oleo/quicklisp.lisp")))))

;;(setq sb-ext:*evaluator-mode* :interpret)

(defun quick ()
   ;;; Check for --no-linedit command-line option.
  #+ :quicklisp
  (if (member "--no-linedit" sb-ext:*posix-argv* :test 'equal)
    (setf sb-ext:*posix-argv* (remove "--no-linedit" sb-ext:*posix-argv* :test 'equal))
    (progn
      (if (interactive-stream-p *standard-output*)
    (require :sb-aclrepl)
    (format *standard-output* "~&Not Interactive!~&"))
      (if (find-package :sb-aclrepl)
    (progn
      (push :aclrepl cl:*features*)
      (setq sb-aclrepl:*max-history* 100)
      (setf (sb-aclrepl:alias "asdc") #'(lambda (sys) (asdf:operate 'asdf:compile-op sys)))
      (sb-aclrepl:alias "l" (sys) (asdf:operate 'asdf:load-op sys))
      (sb-aclrepl:alias "t" (sys) (asdf:operate 'asdf:test-op sys))
      ;; The 1 below means that two characaters ("up") are required
      (sb-aclrepl:alias ("up" 1 "Use package") (package) (use-package package))
      ;; The 0 below means only the first letter ("r") is required, such as ":r base64"
      (sb-aclrepl:alias ("require" 0 "Require module") (sys) (require sys)))
    (setq cl:*features* (delete :aclrepl cl:*features*))))))

;;;;;;;;;;;;;;;;;;
#- :quicklisp
(init-quick)

#+ :quicklisp
(quick)
;;;;;;;;;;;;;;;;;;
(asdf:clear-source-registry)
(asdf:load-system :asdf)

#-asdf
(error "You lose")

(defmethod asdf:perform :around ((o asdf:load-op)
                                 (c asdf:cl-source-file))
   (handler-case (call-next-method o c)
      ;; If a fasl was stale, try to recompile and load (once).
      (sb-ext:invalid-fasl ()
         (asdf:perform (make-instance 'asdf:compile-op) c)
         (when (next-method-p) (call-next-method)))))


(asdf:initialize-source-registry
 `(:source-registry
   (:tree "/home/oleo/common-lisp/source/asdf/")
   (:tree "/home/oleo/common-lisp/source/asdf/ext/")
   (:tree "/home/oleo/source/quicklisp/software/")
   (:tree "/home/oleo/source/clim-work/mcclim-0.9.7-imbolc/")
   (:tree "/home/oleo/climacs-gitlab/")
   (:tree "/home/oleo/prg/lisp/lisp/")
   :default-registry
   :inherit-configuration))

(asdf:initialize-output-translations
 `(:output-translations
   #.(let ((wild-subdir
        (make-pathname :directory '(:relative :wild-inferiors)))
       (wild-file
        (make-pathname :name :wild :version :wild :type :wild)))
       `((:root ,wild-subdir ,wild-file)
     (:user-cache ,wild-subdir ,wild-file)))
   :inherit-configuration))

(defun pds ()
     (progn
       (load "/home/oleo/prg/lisp/lisp/ppmx.lisp")
       (load "/home/oleo/prg/lisp/lisp/dtrace.lisp")
       (load "/home/oleo/prg/lisp/lisp/sdraw.lisp")))

(defun lold ()
     (progn
       (load "/home/oleo/prg/lisp/lisp/package.lisp")
       (load "/home/oleo/prg/lisp/lisp/onlisp-util.lisp")
       (load "/home/oleo/prg/lisp/lisp/onlisp-app.lisp")
       (load "/home/oleo/prg/lisp/lisp/lol-working.lisp")
       (load "/home/oleo/prg/lisp/lisp/generators.lisp")))

;(defun acl2 ()
;  (load "/home/oleo/prg/lisp/lisp/acl2.lisp"))

(export 'cl-user::pds)
(export 'cl-user::lold)
;(export 'cl-user::acl2)

(when (not (find-package :sb-aclrepl))
  (require :sb-aclrepl))

(when (not (find-package :sb-posix))
      (require :sb-posix))

(when (not (find-package :sb-bsd-sockets))
  (require :sb-bsd-sockets))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setf (logical-pathname-translations "norvig")
  `(("norvig:**;*.*.*" "/home/oleo/prg/lisp/paip-pjb/norvig/**/*.*")))

(setq *default-pathname-defaults*
  (merge-pathnames
    *default-pathname-defaults*
    (make-pathname :directory '(:relative "prg/lisp/paip-pjb/"))))

(in-package :cl-user)

(asdf:load-system :clx)

(in-package xlib)

(defun display-keyboard-mapping (display)
  (declare (type display display))
  (declare (clx-values (simple-array keysym (display-max-keycode keysyms-per-keycode))))
  (setf (display-keysym-mapping display) (keyboard-mapping display)))

(in-package :cl-user)

;;newlim-init.lisp
(setq
 *print-pretty* t
 *print-escape* nil
 *print-circle* nil
 *print-right-margin* 110
 *read-default-float-format* 'double-float
 *readtable* (copy-readtable nil))
;;*break-on-signals* nil)

(if (not (member :rune-is-character *features*))
    (push :rune-is-character *features*))

(defun compiler-policy () (funcall (lambda () (sb-ext:describe-compiler-policy))))

(defvar *last-package* nil)
(defvar *cached-prompt* nil)
(defvar *prompt* nil)

(defun package-prompt (stream)
  (unless (eq *last-package* *package*)
    (setf *cached-prompt*
      (concatenate 'string (or (first (package-nicknames *package*))
                   (package-name *package*))
               "> "))
    (setf *last-package* *package*))
  (terpri)
  (princ *cached-prompt* stream))

(setf sb-int:*repl-prompt-fun* #'package-prompt)

(defun date ()
(progn (terpri t) (run-program "/usr/bin/date" '() :output t) (values)))

(defun datetime (&key (as-list nil) (time nil) (date nil))
  (multiple-value-bind (second minute hour day month year day-of-week dst-p tz)
      (get-decoded-time)
    (let* ((day-names
            '("Monday" "Tuesday" "Wednesday"
              "Thursday" "Friday" "Saturday"
              "Sunday"))
           (now (format nil "~2,'0d:~2,'0d:~2,'0d" hour minute second))
           (today (format nil "~a, ~2,'0d.~2,'0d.~d, GMT~@d" (nth day-of-week day-names) day month year (- tz)))
           (result
            (format nil "time: ~2,'0d:~2,'0d:~2,'0d~%date: ~a, ~2,'0d.~2,'0d.~d, GMT~@d" hour minute second
                    (nth day-of-week day-names) day month year (- tz))))
      (cond (as-list
             (multiple-value-list
              (with-input-from-string (s result) (values (intern (read-line s)) (intern (read-line s))))))
            (time now)
            (date today)
            (t
             (with-input-from-string (s result) (values (intern (read-line s)) (intern (read-line s)))))))))

(asdf:load-system :alexandria)
(asdf:load-system :bordeaux-threads)
(asdf:load-system :fiveam)
(asdf:load-system :cl-fad)
(asdf:load-system :trivial-garbage)
(asdf:load-system :spatial-trees)
(asdf:load-system :flexichain)
(asdf:load-system :opticl)
(asdf:load-system :mcclim)
(asdf:load-system :mcclim-clx)
(asdf:load-system :clouseau)
(asdf:load-system :clim-debugger)
(asdf:load-system :clim-listener)
(asdf:load-system :climacs)

(defun my-climacs ()
  (load "/home/oleo/quicklisp/local-projects/climacs/packages.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/text-syntax.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/typeout.lisp")

  (load "/home/oleo/quicklisp/local-projects/climacs/gui.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/core.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/groups.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/io.lisp")

  (load "/home/oleo/quicklisp/local-projects/climacs/developer-commands.lisp")

  (load "/home/oleo/quicklisp/local-projects/climacs/climacs-lisp-syntax.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/misc-commands.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/climacs-lisp-syntax-commands.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/structured-editing.lisp")

  (load "/home/oleo/quicklisp/local-projects/climacs/search-commands.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/window-commands.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/file-commands.lisp")
  (load "/home/oleo/quicklisp/local-projects/climacs/climacs.lisp"))

(in-package :clim-user)

(setq
  *print-pretty* t
  *print-escape* nil
  *print-circle* nil
  *print-right-margin* 110
  *read-default-float-format* 'double-float
  *readtable* (copy-readtable nil))
;;*break-on-signals* nil)

(defun dohash (table)
  (let (result)
    (maphash (lambda (k v) (push (list k v) result)) table)
    (nreverse result)))

(defun nil-as-list ()
  (set-pprint-dispatch
    '(eql nil)
    (lambda (srm el)
      (cond
       ((null (cdr el))
    (format srm "()"))
       (t
    (pprint-fill srm el t))))
    2))

(defun remove-nil-as-list ()
  (let*
    ((*print-pretty* nil)
      (dispatch-table (slot-value *print-pprint-dispatch* 'sb-pretty::entries)))
    (dolist (x dispatch-table)
      (cond
    ((equal '(eql ()) (slot-value x 'sb-pretty::type))
      (setf (slot-value *print-pprint-dispatch* 'sb-pretty::entries)
        (remove x dispatch-table)))))))

(defun pprint-dispatch-entries (&optional p)
  (let*
      ((*print-pretty* nil)
       (dispatch-table (slot-value *print-pprint-dispatch* 'sb-pretty::entries)))
    (if p
        (dolist (x dispatch-table)
          (print x))
        dispatch-table)))

(defun pprint-dispatch-cons-entries ()
  (let*
    ((*print-pretty* nil)
      (dispatch-table (slot-value *print-pprint-dispatch* 'sb-pretty::cons-entries)))
    (loop for key being the hash-keys of dispatch-table
      using (hash-value value)
      collect (list key value))))

(defun pprint-dispatch-find (term) ;; (pprint-dispatch-find '(eql ())) after (nil-as-list) for example
  (let*
    ((*print-pretty* nil)
      (dispatch-table (slot-value *print-pprint-dispatch* 'sb-pretty::entries)))
    (dolist (x dispatch-table)
      (cond
        ((equal term (slot-value x 'sb-pretty::type))
         (return
          (values :entry x
                  :type (slot-value x 'sb-pretty::type)
                  :priority (slot-value x 'sb-pretty::priority)
                  :function (slot-value x 'sb-pretty::fun))))))))

(defun pprint-dispatch-cons-find (term)
  (let* ((*print-pretty* nil) (dispatch-table (slot-value *print-pprint-dispatch* 'sb-pretty::cons-entries)))
    (labels ((dohash (table)
               (let (result)
                 (maphash (lambda (k v) (push (list k v) result)) table)
                 (nreverse result))))
      (dolist (x (dohash dispatch-table))
        (cond
         ((equal term (first x))
          (return
           (values :entry x
                   :type (slot-value (second x) 'type)
                   :function (slot-value (second x) 'sb-pretty::fun)
                   :priority (slot-value (second x) 'sb-pretty::priority)))))))))

(defun pprint-dispatch-remove-quote ()
  (let ((dispatch-table (slot-value *print-pprint-dispatch* (quote sb-pretty::cons-entries))))
    (loop for key being the hash-keys of dispatch-table using (hash-value hash-value)
      collect (if (equal (quote (cons (eql quote))) (slot-value hash-value (quote type)))
        (remhash key dispatch-table)))))


(defun remove-from-pprint-dispatch (term)
  (let ((dispatch-table (slot-value *print-pprint-dispatch* (quote sb-pretty::cons-entries))))
    (loop for key being the hash-keys of dispatch-table using (hash-value hash-value)
      collect (if (equal term (slot-value hash-value (quote type)))
        (remhash key dispatch-table)))))

(defmacro do-hash ((key-var val-var hash-expr &optional result-form) &body body)
  (let ((hash-var (gensym "HASH-")))
    `(loop with ,hash-var = ,hash-expr
       for ,key-var being the hash-keys of ,hash-var
       for ,val-var being the hash-values of ,hash-var
       do (progn ,@body)
       finally (return ,result-form))))

;;; usage like...
;;;(do-hash (k v table (dohash table))
;;;  (terpri)
;;;  #+:clim
;;;  (with-drawing-options (t :text-size 16 :text-face :bold)
;;    (format t "key: ~s, value: ~s" k v)))


;; don't forget if you want your 'a stuff to expand to (quote a) properly set *print-pretty* to nil (disable)
;; else lookups are made via the pprint dispatch tables and the pprinter has its own ways of printing stuff!
;; especially don't forget to disable it when using/defining macro character functions!
;; else expansions might not be the same as expected which will confuse just more....
;; http://www.lispworks.com/documentation/HyperSpec/Body/22_ab.htm

;;;; and tho *print-pretty* is a special var disabling/enabling it from the listener won't affect it's value
;;;; in the sbcl repl! (threads ?)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;,;;;;;;;;;;;;;;;;;


(defun current-view (&optional (pane-name *standard-output*))
  (funcall
    (lambda ()
      (stream-default-view pane-name))))

(defun current-frame-name (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (or
    (type-of frame)
    (slot-value frame 'climi::name)))))

(defun current-frame (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (slot-value (frame-top-level-sheet frame) 'climi::frame))))

(defun current-frame-class (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (class-of frame))))

(defun current-frame-class-description ()
  (funcall
    (lambda ()
      (describe (current-frame-class)))))

(defun current-frame-instance (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      frame)))

(defun current-frame-instance-description ()
  (funcall
    (lambda ()
      (describe (current-frame-instance)))))

(defun current-frame-panes (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (slot-value frame 'climi::named-panes))))

(defun current-frame-layouts (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (slot-value frame 'climi::layouts))))

(defun current-frame-layout (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (slot-value frame 'climi::current-layout))))

(defun current-frame-layout-panes (&optional (frame *application-frame*))
  (funcall
    (lambda ()
      (slot-value frame 'climi::panes-for-layout))))

;;(defparameter *default-font-family-name* "-*-unifont-*-*-*-*-*-180-*-*-*-*-iso10646-1")
(defparameter *default-font-family-name* "-*-dejavu sans mono-bold-r-normal-*-*-180-*-*-*-*-iso10646-1")
;;  (setq *default-font-family-name* (climi::make-text-style "misc-fixed" "medium-r" 18))

(defun update-map-for-face-with-name (map family name)
  (let ((current-face (getf map family)))
    (unless current-face
      (error "family ~A not found!" family))
    (substitute `(,name ,@(cdr current-face)) current-face map)))

(defun set-fix ()
  (let ((*default-font-family-name* "-*-unifont-*-*-*-*-*-180-*-*-*-*-iso10646-1"))
    (setf clim-clx::*clx-text-family+face-map*
      (clim-user::update-map-for-face-with-name
    clim-clx::*clx-text-family+face-map* :fix clim-user::*default-font-family-name*))))

;#+nil

(defmethod asdf:perform :around ((o asdf:load-op) (c (eql (asdf:find-system :mcclim-clx))))
  `(defmethod initialize-instance :around ((port ,(intern "CLX-PORT" :clim-clx)) &rest args)
     (setf (symbol-value (intern "*CLX-TEXT-FAMILY+FACE-MAP*" :clim-clx))
       (update-map-for-face-with-name
        (symbol-value (intern "*CLX-TEXT-FAMILY+FACE-MAP*" :clim-clx))
        :fix clim-user::*default-font-family-name* :large))
     (sleep 0.01)
     (when (next-method-p) (apply #'call-next-method port args))))

(in-package :cl-user)

(defun print-thread-info ()
      (let* ((curr-thread (bt:current-thread))
             (curr-thread-name (bt:thread-name curr-thread))
             (all-threads (bt:all-threads)))
        (format t "Current thread: ~a~%~%" curr-thread)
        (format t "Current thread name: ~a~%~%" curr-thread-name)
        (format t "All threads:~% ~{~a~%~}~%" all-threads))
      nil)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun thread-list ()
    (funcall
      (let ()
    (lambda ()
      (sb-thread:list-all-threads)))))

  (defun current-threads ()
    (let ()
      (funcall
      (lambda () (thread-list)))))

  (setf (symbol-value 'thread-list) (funcall (symbol-function 'thread-list)))
  (setf (symbol-value 'current-threads) (current-threads))

  (defun kill-first-of ()
    (sb-thread:terminate-thread (first (sb-thread:list-all-threads))))

  (defun kill-last-of ()
    (sb-thread:terminate-thread (first (last (sb-thread:list-all-threads)))))

  (defun kill-nth-of (n)
    (sb-thread:terminate-thread (nth n (sb-thread:list-all-threads)))))

(defun kill-listener ()
  (let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal "Listener" (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))

(defun kill-maxima ()
  (let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal "Maxima Listener" (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))

(defun kill-climacs ()
  (let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal (or "Climacs-RV" "Climacs") (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))

(defun kill-beirc ()
  (let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal "BEIRC GUI process" (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))

(defun kill-beirc-ticker ()
(let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal "Beirc Ticker" (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))

(defun kill-irc-message-muffling-loop ()
  (let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal "IRC Message Muffling Loop" (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))

(defun kill-closure ()
  (let ((thread-list (sb-thread:list-all-threads)))
    (dolist (x thread-list)
      (cond ((equal "Closure" (sb-thread:thread-name x))
          (sb-thread:terminate-thread x))))))


(defun ucs-insert (&optional character (count 1))
  "given a character returns the unicode symbol or reads input and then returns the symbol"

  (if character
    (let ((result (or (string (code-char character)) (string character))))
      (progn
        (dotimes (i count)
      (format t "~s" result))))

    (progn
      (let* (
          (character (read-char))
          (result (or (string character) (string (code-char character)))))
    (dotimes (i count)
      (format t "~s" result))))))

(defun ascii-table ()
  (let ((i -1))
    (format t "~&ASCII characters 32 thru 127.~&~%")
    (format t "   Dec  Hex  Char         |   Dec  Hex   Char         |   Dec  Hex   Char         |   Dec  Hex   Char~%")
    (loop while (< i 31) do
      (princ (format nil "~4d ~4x    ~12s | ~4d ~4x    ~12s | ~4d ~4x    ~12s | ~4d ~4x    ~12s~%"
           (setq i (+ 33  i)) i (code-char i)
           (setq i (+ 32 i)) i (code-char i)
           (setq i (+ 32 i)) i (code-char i)
           (setq i (+ 1 i)) i (code-char i)))
      (setq i (- i 95)))) (values))

(defun ascii-table-s ()
  (let ((i -1))
    (format t "~&ASCII characters 32 thru 127.~&~%")
    (format t "   Dec  Hex  Char         |   Dec  Hex   Char         |   Dec  Hex   Char         |   Dec  Hex   Char~%")
    (loop while (< i 31) do
      (princ (format nil "~4d ~4x    ~12s | ~4d ~4x    ~12s | ~4d ~4x    ~12s | ~4d ~4x    ~12s~%"
           (setq i (+ 33  i)) i (string (code-char i))
           (setq i (+ 32 i)) i (string (code-char i))
           (setq i (+ 32 i)) i (string (code-char i))
           (setq i (+ 1 i)) i (string (code-char i))))
      (setq i (- i 95)))) (values))

(defun extended-table ()
  (let ((i 128))
    (format t "~&extended ASCII characters (unicode) 128 thru 256.~&~%")
    (format t " Dec   Hex   Char  |  Dec   Hex   Char~%")
    (loop while (< i 256) do
      (princ (format nil "~4d ~4x ~50s  |  ~4d ~4x ~50s~%"
           i i (code-char i)
           (incf i) i (code-char i)))
      (incf i))) (values))

(defun extended-table-s ()
  (let ((i 128))
    (format t "~&extended ascii characters (unicode) 128 thru 256.~&~%")
    (format t " dec   hex   char  |  dec   hex   char~%")
    (loop while (< i 256)
      do (princ
       (format nil "~4d ~4x ~50s  |  ~4d ~4x ~50s~%"
         i i (string (code-char i))
         (incf i) i (string (code-char i))))
      (incf i))) (values))

(defun ucs-codes-t (start row col) ;; terminal version
  (let ((x start) (somechars nil))
    (do ((i 1 (1+ i)))
      ((> i row))
      (terpri)
      (do ((j 1 (1+ j)))
    ((> j col))
    (format t "~s " (string (code-char x)))
    (incf x)))))

(defun ucs-codes-tl (start row col) ;; terminal-list version
  (let ((x start) (somechars nil))
    (do ((i 1 (1+ i)))
      ((> i row))
      (do ((j 1 (1+ j)))
    ((> j col))
    (setq somechars (append somechars (list (string (code-char x)))))
    (incf x))) somechars))

(defun change-directory (pathname)
  "Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*"
  #+CMU (unix:unix-chdir (namestring pathname))
  #+scl (unix:unix-chdir (ext:unix-namestring pathname))
  #+clisp (ext:cd pathname)
  #+sbcl (sb-posix:chdir (pathname (namestring pathname)))
  (setf *default-pathname-defaults* (pathname (namestring pathname))))

(defun list-dir (pathname)
  ;; (list-dir '/home/oleo) for example
  (loop for f in
    (directory (make-pathname :directory (string-downcase pathname) :name :wild :type :wild))
    collect f))

(defun print-dir (pathname)
  ;; (print-directory '/home/oleo) for example
  (loop for f in
    (directory (make-pathname :directory (string-downcase pathname) :name :wild :type :wild))
    do (print f)))

(in-package :clim-user)
#+asdf
#+clim
(asdf:load-system :clim-examples)

(defun clim-demos ()
   (clim-sys:make-process
    (lambda () (clim-demo:demodemo)) :name "clim-examples"))

(in-package :clim-listener)


(setf drei-lisp-syntax::+bold-face-drawing-options+
      (drei:make-drawing-options :face (drei:make-face :ink +dark-goldenrod+ :style (climi::make-text-style nil :bold nil))))
;(setf drei::+default-drawing-options+
;      (drei:make-drawing-options :face (drei:make-face :ink +red+ :style (clim:make-text-style nil :bold nil))))

#+:asdf
(asdf:oos 'asdf:load-op :functional-geometry)

(defmethod read-frame-command ((frame listener) &key (stream *standard-input*))
  "Specialized for the listener, read a lisp form to eval, or a command."
  (multiple-value-bind (object type)
      (let ((*command-dispatchers* '(#\,)))
        (with-text-style (stream (make-text-style :fix nil :very-large))
          (accept 'command-or-form :stream stream :prompt nil
                  :default "hello" :default-type 'empty-input)))
    (cond
      ((presentation-subtypep type 'empty-input)
       ;; Do nothing.
       `(com-eval (values)))
      ((presentation-subtypep type 'command) object)
      (t `(com-eval ,object)))))


(defun print-listener-prompt (stream frame)
  (declare (ignore frame))
  (with-text-style (stream (climi::make-text-style :fix :bold :very-large))
  (with-output-as-presentation (stream *package* 'package :single-box t)
    (print-package-name stream))
  (princ "> " stream)
  (let ((h (- (bounding-rectangle-height (stream-output-history stream))
              (bounding-rectangle-height (or (pane-viewport stream) stream)))))
    (scroll-extent stream 0 (max 0 h)))))

(define-application-frame listener (standard-application-frame)
    ((system-command-reader :accessor system-command-reader
                :initarg :system-command-reader
                :initform t))
    (:panes (interactor-container
             (make-clim-stream-pane
              :type 'listener-interactor-pane
          :background +gray10+
          :foreground +wheat4+
          :width 1200
          :height 768
          :text-margin 1200
              :name 'interactor :scroll-bars :both
              :end-of-line-action :wrap
          :end-of-page-action :scroll
              :default-view +listener-view+))
            (doc :pointer-documentation :default-view +listener-pointer-documentation-view+
         :end-of-line-action :wrap :end-of-page-action :wrap :scroll-bars :both)
            (wholine (make-pane 'wholine-pane
                                :display-function 'display-wholine :scroll-bars nil
                                :display-time :command-loop :end-of-page-action :wrap :end-of-line-action :wrap)))
  (:top-level (default-frame-top-level :prompt 'print-listener-prompt))
  (:command-table (listener
                   :inherit-from (application-commands
                                  lisp-commands
                                  asdf-commands
                                  filesystem-commands
                                  show-commands)
                   :menu (("Listener"   :menu application-commands)
                          ("Lisp"       :menu lisp-commands)
                          ("Filesystem" :menu filesystem-commands)
                          ("Show"       :menu show-commands))))
  (:disabled-commands com-pop-directory com-drop-directory com-swap-directory)
  (:menu-bar t)
  (:layouts (default
          (vertically ()
                interactor-container
                (1/6 doc)
                wholine))))

(defun run-listener (&key (new-process nil)
                          (debugger t)
                          (width 1200)
                          (height 768)
                          port
                          frame-manager
              (text-margin 1200)
              (end-of-line-action :wrap)
              (end-of-page-action :wrap)
                          (process-name "Listener")
                          (package :clim-user))
  (let* ((fm (or frame-manager (find-frame-manager :port (or port (find-port)))))
         (frame (make-application-frame 'listener
                    :frame-manager fm
                    :width width
                    :height height
                    :text-margin text-margin
                    :end-of-line-action end-of-line-action
                    :end-of-page-action end-of-page-action))
     (climi::*default-text-style* (climi::make-text-style :fix :roman :very-large)))
    (flet ((run ()
        (let ((*package* (find-package package)))
          (unwind-protect
              (if debugger
              (clim-debugger:with-debugger () (run-frame-top-level frame))
                        (run-frame-top-level frame))
            (disown-frame fm frame)))))
      (if new-process
          (values (clim-sys:make-process #'run :name process-name)
              frame)
        (run)))))

(defmethod frame-standard-output ((frame listener))
  (get-frame-pane frame 'interactor))


(in-package :cl-user)

(setf climacs-gui::*climacs-text-style* (climi::make-text-style :fix :bold :very-large))

(defun clme ()
  (unwind-protect
      (sb-sys:without-interrupts
       (sb-sys:with-local-interrupts
    (values
     (sleep 0.01)
     (let ((climacs-gui::*default-external-format* 'utf-8)
           (climacs-gui::*climacs-text-style* (climi::make-text-style :fix :roman :very-large)))
       (climacs:climacs-rv :new-process t :width 1500 :height 768))
       (sleep 0.01))))))

#+clim
(defun clmi ()
  (unwind-protect
      (sb-sys:without-interrupts
       (sb-sys:with-local-interrupts
    (values
     (sleep 0.01)
     (let ((*debugger-hook* #'clim-debugger:debugger)
           (*invoke-debugger-hook* #'clim-debugger:debugger)
           (climi::*default-text-style* (climi::make-text-style :fix :roman :very-large))
           (*trace-output* *standard-output*))
       (clim-listener:run-listener :new-process t :width 1500 :height 768))
       (sleep 0.01))))))

#+clim
(defun clm ()
  (sb-thread:release-foreground (clmi))
  (sb-thread:release-foreground (clme)))

(defun next-epsi (epsi) (/ epsi 2))

(defun epsi-sig-single-p (epsi) (> (+ 1.0f0 epsi) 1.0f0))
(defun epsi-sig-double-p (epsi) (> (+ 1.0d0 epsi) 1.0d0))

(defun is-epsi-single-p (epsi)
  (and (epsi-sig-single-p epsi)
    (not (epsi-sig-single-p (next-epsi epsi)))))

(defun is-epsi-double-p (epsi)
  (and (epsi-sig-double-p epsi)
    (not (epsi-sig-double-p (next-epsi epsi)))))

(defun find-epsi-single (&OPTIONAL (epsi 1.0f0))
  (if (is-epsi-single-p epsi)  ; if the next epsi candidate isn't significant
    epsi  ; we have found epsilon
    (find-epsi-single (next-epsi epsi)))) ; otherwise, go smaller

(defun find-epsi-double (&OPTIONAL (epsi 1.0d0))
  (if (is-epsi-double-p epsi)  ; if the next epsi candidate isn't significant
    epsi  ; we have found epsilon
    (find-epsi-double (next-epsi epsi)))) ; otherwise, go smaller

(in-package :cl-user)

(let ()
(format t "~% machine-epsilon-single: ~a ~% machine-epsilon-double: ~a ~% epsi-sig-single-p? ~a ~% epsi-sig-double-p? ~a ~%"(find-epsi-single) (find-epsi-double) (epsi-sig-single-p (find-epsi-single)) (epsi-sig-double-p (find-epsi-double))) (values))

(let ()
(terpri t)
(let () (format t "Happy lisping!~%") (values))
;;(write-char #\Newline t) ;;is identical to (terpri t)
(terpri t)
(let () (format t "Machine: ~a~&" (machine-version)) (values))
(let () (format t "OS: ~a ~a~&" (software-type) (software-version)) (values))
(let () (format t "Host: ~a~&" (machine-instance)) (values))
(let () (format t "Implementation: ~a~&" (lisp-implementation-type)) (values))
(let () (format t "Type: ~a~&" (machine-type)) (values))
(let () (format t "Version: ~a~&" (lisp-implementation-version)) (values))
(terpri t)
(let () (format t "Time: ~a Date: ~a" (datetime :time t) (datetime :date t)) (values))
(terpri)
(values))

(clm)