(require 'cgn) (progn (use-package :cgn) (use-package :ltk)) ;; Inputs is of the form ;; k => name provided by user for input ;; v => the code generated to make an instance ;; ex: (:scale pony 0 10 1) creates an entry ;; where pony=>(make-instance 'scale ...) (defparameter *inputs* (make-hash-table)) ;; The parameters passed to the action function. (defparameter *params* nil) ;; Resets the model (defun reset-inputs () (setf *inputs* (make-hash-table)) (setf *params* '())) ;; Converts a keyworded form to the appropriate LTK make-instance. ;; Side-effect: Adds the instance to *inputs* (defun convert-to-instance (keyword) (let ((key (first keyword)) ; eg: :scale (name (second keyword)) ; (vals (cddr keyword)) ; all additional parameters (special (eql 'special (first (last keyword)))) tmp) (cond ((equal key :scale) (progn (setf tmp `(make-instance 'scale :master main-label :label ,(format nil "~A" name) :from ,(first vals) :to ,(second vals) :digits 5 :resolution ,(or (third vals) 1) :troughcolor ,(if special :red :black) :orientation 'horizontal)) (setf (gethash name *inputs*) tmp)))) tmp)) (defmacro defmodel (name inputs model importance &body action) (reset-inputs) (let ( letz ; all LTK forms packer ; generated from letz, a sequence of (pack NAME) ui-name model-name function-name function-parameters importance-name ) ; Generates two symbols: NAME-MODEL and NAME-PROCESSOR (setf model-name (intern (format nil "~A-MODEL" name))) (setf function-name (intern (format nil "~A-PROCESSOR" name))) (setf ui-name (intern (format nil "~A-UI" name))) (setf importance-name (intern (format nil "~A-IMPORTANCE" name))) ; Two glorious effects: ; a. Generate a parameter listing for the processor function from the inputs. ; b. Convert the :scale syntax to LTK syntax (dolist (i inputs) (setf function-parameters (append function-parameters (list (second i)))) (setf *params* (append *params* (list `(value ,(second i))))) (convert-to-instance i)) (setf letz (append letz (list `(display-label (make-instance 'labelframe :text "Display"))))) (setf letz (append letz (list `(main-label (make-instance 'labelframe :text "Inputs"))))) (setf letz (append letz (list `(action-label (make-instance 'labelframe :text "Action"))))) (setf letz (append letz (list `(kanvas (make-canvas display-label :width 384 :height 865))))) (maphash #'(lambda (k v) (setf letz (append letz (list (list k v))))) *inputs*) (setf letz (append letz (list `(img0 (make-image))))) (setf letz (append letz (list `(img1 (make-image))))) (setf letz (append letz (list `(img2 (make-image))))) (setf letz (append letz (list `(action2 (make-instance 'button :master action-label :text "Generate 3D" :command #'(lambda () (progn (funcall #',function-name ,@*params*) (sleep 1) (image-load img0 "0.gif") (image-load img1 "1.gif") (image-load img2 "2.gif") (create-image kanvas 0 0 :image img0) (create-image kanvas 0 289 :image img1) (create-image kanvas 0 578 :image img2)))))))) (setf letz (append letz (list `(action3 (make-instance 'button :master action-label :text "Importance" :command #'(lambda () (progn (funcall #',importance-name ,@function-parameters)))))))) (setf packer (mapcar #'(lambda (l) (cond ((or (eql 'display-label l) (eql 'kanvas l)) `(pack ,l :side :right)) ((or (eql 'img0 l) (eql 'img1 l) (eql 'img2 l)) nil) (t `(pack ,l)))) (mapcar #'first letz))) (eval `(defun ,ui-name () (with-ltk () (let* ,letz ,@packer)))) (eval `(defun ,model-name ,function-parameters ,@model)) (eval `(defun ,importance-name ,function-parameters ,@importance)) `(defun ,function-name ,function-parameters (let* ((path (make-pathname :name "tmp.dat")) (output-stream (open path :direction :output :if-exists :supersede))) (with-gnuplot ('linux) (set-grid 'on) (format-gnuplot "set xticks 1") (format-gnuplot "set yticks 1") ,@action))))) (defparameter *p-values* #(.25 .22 .14 .14 .069 .064 .033 .033 .022 .02 .013)) (defparameter *s-values* #(.728 .166 .065 .018 .018 .006)) (defparameter *DL* #\Tab) ;(defun update-scale-color () ; (configure 'lambda troughcolor :blue)) (defmacro set-labels (x y z) `(progn (format-gnuplot "set xlabel '~A'" ,x) (format-gnuplot "set ylabel '~A'" ,y) (format-gnuplot "set zlabel '~A'" ,z))) (defmacro generate-thumbs (viewx viewy dx dy) `(progn (format-gnuplot "set terminal gif") (format-gnuplot "set size .6,.6") (dotimes (i 3) (format-gnuplot (format nil "set view ~A,~A" (+ ,viewx (* (1+ i) ,dx)) (+ ,viewy (* (1+ i) ,dy)))) (format-gnuplot (format nil "set output \"~A.gif\"" i)) (format-gnuplot "splot 'tmp.dat' with linespoints")) (format-gnuplot "set terminal wxt") (format-gnuplot "set size 1,1") (format-gnuplot "set output"))) (defun calculate-t (l j) (/ (* (exp (- l)) (expt l j)) (n! j))) (defun n! (n) (if (or (= n 0) (= n 1)) 1 (* n (n! (- n 1))))) (defmodel evett ((:scale lamb 1 10) (:scale fvalue .01 .25 .01 special) (:scale n 1 5) (:scale lr 25 225 25)) ;This becomes the "model" accessible by evett-model. ((min lr (+ (/ (* (elt *p-values* 0) (calculate-t lamb (+ 1 n))) (* (elt *p-values* 1) (elt *s-values* n) fvalue)) (calculate-t lamb 0)))) ;Importance isn't implemented for this model. Yet? ((configure lamb :troughcolor (intern (format nil "gray~A" 30))) (configure n :troughcolor :green)) ;This is the business that generates the 3D image. It can't be removed. (format output-stream "#LAMBDA ~A N ~A LR~%" *DL* *DL*) (dotimes (x (round lamb)) (dotimes (y (round n)) (format output-stream "~A ~A ~A ~A ~A~%" (+ 1 x) *DL* (1+ y) *DL* (evett-model (1+ x) fvalue (1+ y) lr)))) (close output-stream) (format-gnuplot "set dgrid3d") (set-labels "LAMBDA" "N" "LR") (generate-thumbs 30 40 40 30) (format-gnuplot "splot 'tmp.dat' with linespoints"))