new file mode 100644

@@ -0,0 +1,124 @@

+(defpackage #:test-clim

+  (:use #:clim #:clim-lisp))

+(in-package #:test-clim)

+(shadow 'inspect)

+

+(defun tokenize (string)

+  (loop with result = '()

+        with word = '()

+        for char across string

+        when (or (char= char #\space) (char= char #\newline) (char= char #\tab))

+          do (progn (push (reverse (coerce word 'string)) result)

+                    (setf word '()))

+

+        unless (or (char= char #\space) (char= char #\newline) (char= char #\tab))

+          do (push char word)

+

+        finally (progn (push (reverse (coerce word 'string)) result)

+                       (return (reverse result)))))

+

+(defparameter *records*

+  '(

+"Networks are in trouble. The volume of data, applications and transactions hitting data centers is increasing at an exponential pace. Add in predictions that by 2020 users will own as many as 25 connected devices and, according to Cisco, the Internet of Things will account for as many as 50 billion new IP-enabled devices and you can see a tsunami of traffic headed our way."

+

+"Networking systems built around multi-purpose processors are about to slam into a price/performance wall that will either choke traffic or break networking budgets."

+

+"Recently, Google engineers blogged about a new ASIC they developed, called a Tensor Processing Unit designed to accelerate machine-learning applications.  They argue that this ASIC has fast-forwarded their technology by seven years, allowing them to leapfrog competition and “squeeze more operations per second into the silicon, use more sophisticated and powerful machine learning models, and apply these models more quickly, so users get more intelligent results more rapidly.”"

+

+"There are a number of challenges for other companies interested in this approach. The development of ASICs is resource-intensive and time consuming."

+

+"Setting aside issues like the shortage of available talent and the average of four years to develop and bring a new ASIC to market, the material costs alone are high. The manufacturing of a typical two-gram chip requires 1.6 kilograms of fossil fuel, 72 grams of chemicals, and 32 kilograms of water. The materials involved in making a 32Mbit RAM chip can add up to as much as 630 times the mass of the final product."

+

+"Market analysts and business leaders for years have discounted the value of ASICs. They argued that the time to develop the hardware, design the firmware, and incorporate the technology into current programming and development processes is too expensive. They complain that it can slow down their ability to respond to market changes and say multi-purpose CPUs are fast, cheap and easy to write software for."

+

+"However, general-purpose microprocessors are about to run up against the limits of Moore's law. Features in some of Intel’s latest chips are said to be just 100 atoms wide. To keep up with current demand, that same chip by 2020 will need to have features ten atoms wide."

+

+"IBM announced they are spending $3 billion to develop a new generation of microprocessors. It estimates its state-of-the-art chips will use a 7nm process in five years. At that size reliability becomes a serious issue with manufacturing errors and even quantum challenges."

+    ))

+

+(declaim (optimize (debug 3)))

+

+(define-application-frame

+  test-clim ()

+

+  ()

+  (:pointer-documentation t)

+  (:panes

+    (app :application

+         :height 400 :width 600

+         :display-time nil

+         :scroll-bars :vertical)

+    (int :interactor :height 100 :width 600))

+  (:layouts

+    (default (horizontally () app int))))

+

+(defun app-main ()

+  (let ((frame (make-application-frame 'test-clim)))

+    (run-frame-top-level frame)))

+

+(define-test-clim-command (com-quit :name t) ()

+  (frame-exit *application-frame*))

+

+(test-clim::define-test-clim-command (inspect :name t) ()

+ (clouseau:inspector

+   (clim:stream-output-history

+     (clim:find-pane-named clim:*application-frame* 'test-clim::app))))

+

+(define-test-clim-command (com-put-records :name t) ()

+  (let* ((pane (clim:find-pane-named clim:*application-frame* 'app))

+         (history (clim:stream-output-history pane))

+         (record-strings

+           (mapcar (lambda (text)

+                     (with-output-to-string (pane)

+                       (pprint-logical-block (pane (tokenize text))

+                         (pprint-indent :block 4 pane)

+                         (loop

+                           (pprint-exit-if-list-exhausted)

+                           (princ (pprint-pop) pane)

+                           (pprint-exit-if-list-exhausted)

+                           (princ #\space pane)

+                           (pprint-newline :fill pane)))))

+                   *records*))

+         (records (mapcar (lambda (text)

+                            (clim:with-output-to-output-record (pane)

+                              (princ text pane)))

+                          (apply #'concatenate 'list

+                                 (mapcar (lambda (x) (serapeum:split-sequence #\newline x))

+                                         record-strings)))))

+    (loop for n from 0

+          for record in records

+          do (climacs-flexichain-output-history:insert history record n))

+    (climacs-flexichain-output-history:change-space-requirements history)

+    (clim:replay history pane)))

+

+(define-test-clim-command (com-put-records1 :name t) ()

+  (let* ((pane (clim:find-pane-named clim:*application-frame* 'app))

+         (history (clim:stream-output-history pane))

+         (records (mapcar (lambda (text)

+                            (clim:with-output-to-output-record (pane)

+                              (pprint-logical-block (pane (tokenize text))

+                                (pprint-indent :block 4 pane)

+                                (loop

+                                  (pprint-exit-if-list-exhausted)

+                                  (princ (pprint-pop) pane)

+                                  (pprint-exit-if-list-exhausted)

+                                  (princ #\space pane)

+                                  (pprint-newline :fill pane)))))

+                          *records*)))

+    (mapcar (lambda (record)

+              (climacs-flexichain-output-history:insert history record 0)

+              (climacs-flexichain-output-history:change-space-requirements history) 

+              (clim:replay history pane))

+            records)))

+

+(define-test-clim-command (com-initialize :name t) () ()

+  (let ((pane (clim:find-pane-named clim:*application-frame* 'app)))

+    (setf (clim:stream-recording-p pane) nil)

+    ;(setf (clim:stream-end-of-line-action pane) :allow)

+    (change-class (clim:stream-output-history pane)

+                  'climacs-flexichain-output-history:flexichain-output-history

+                  :parent pane)))

+

+

+#+os-macosx (setf mcclim-truetype:*truetype-font-path* "/Library/Fonts/")

+(app-main)

new file mode 100644

@@ -0,0 +1,125 @@

+;;;; it-lookup.lisp

+

+(defpackage #:it-lookup-clim

+  (:use #:clim #:clim-lisp #:it-lookup))

+

+(in-package #:it-lookup-clim)

+(declaim (optimize (debug 3)))

+

+(define-application-frame

+  it-lookup ()

+

+  ((results :initform (make-instance 'it-lookup::it-results :query "amicus") 

+            :accessor results)

+   (cursor :initform 0 :accessor cursor))

+  (:pointer-documentation t)

+  (:panes

+    (app :application

+         :height 400 :width 600

+         :incremental-redisplay t

+         :double-buffering t

+         ;:display-time nil

+         :display-function #'display-app

+         )

+    (int :interactor :height 100 :width 600))

+  (:layouts

+    (default (horizontally () app int))))

+

+(defun display-app (frame pane)

+  (let ((history (stream-output-history pane)))

+    (loop for element across (it-lookup::cases (results frame))

+          do (add-output-record (with-output-to-output-record (pane)

+                                  (terpri pane)   

+                                  (it-lookup::format-result element pane)

+                                  (terpri pane))

+                                history))

+    (climacs-flexichain-output-history:change-space-requirements history) 

+    (clim:replay history pane)))

+

+(define-presentation-type reference ())

+(defmethod it-lookup::format-reference :around ((it-case it-lookup::it-case)

+                                               (stream clim:extended-output-stream))

+  (clim:with-text-style (stream '(:serif :bold 16))

+    (with-output-as-presentation (stream it-case 'reference)

+      (call-next-method))))

+

+(defmethod it-lookup::format-reference :around ((it-case it-lookup::it-case)

+                                               (stream sb-pretty:pretty-stream))

+  (let ((real-stream (it-lookup::get-real-stream stream)))

+    (terpri stream)

+    (it-lookup::format-reference it-case real-stream)))

+

+(defun display-data (&rest args)

+  (get-data))

+

+(defun get-data ()

+  (return-from get-data)

+  (let* ((pane (find-pane-named *application-frame* 'app))

+         (history (stream-output-history pane)))

+    (loop for element across (it-lookup::cases (results *application-frame*))

+          for n from 0

+          do (let ((record (clim:with-output-to-output-record (pane)

+                             (it-lookup::format-result element pane)

+                             (terpri pane))))

+               #|(climb:ou history record n)|#))

+    (climacs-flexichain-output-history:change-space-requirements history) 

+    (clim:replay history pane)))

+

+(defclass no-clear-output-history (climacs-flexichain-output-history:flexichain-output-history)

+  ())

+

+(defmethod clear-output-record ((h no-clear-output-history)))

+

+(defmethod generate-panes :after ((fm frame-manager) (frame it-lookup))

+  (let ((*application-frame* frame))

+    (let ((pane (clim:find-pane-named frame 'app)))

+      (unless pane (break))

+      (setf (clim:stream-recording-p pane) nil)

+      (setf (clim:stream-end-of-line-action pane) :allow)

+      (change-class (clim:stream-output-history pane)

+                    ;'climacs-flexichain-output-history:flexichain-output-history

+                    'no-clear-output-history

+                    :parent pane))))

+

+(defun app-main ()

+  (let* ((frame (make-application-frame 'it-lookup))

+         (*application-frame* frame))

+    (with-accessors ((results results)) frame

+      (parse-results results

+                     (run-query results)))

+    (run-frame-top-level frame)))

+

+(define-it-lookup-command (com-inspect :name t) ()

+  (clouseau:inspector

+    (clim:stream-output-history

+      (clim:find-pane-named clim:*application-frame* 'app))))

+

+(define-it-lookup-command (get-records :name t) ()

+  (get-data))

+

+(define-it-lookup-command (com-quit :name t) ()

+  (frame-exit *application-frame*))

+

+(defparameter *saved-cases* nil)

+(defun save-case (case) (push case *saved-cases*))

+

+(define-it-lookup-command (com-save :name t) ((it-case 'reference))

+  (save-case it-case)

+  it-case)

+

+(define-it-lookup-command (com-prev :name t) ()

+  (let ((results (results *application-frame*)))

+    (with-accessors ((page it-lookup::page)) results

+      (when (> page 0)

+        (decf page)))

+    (parse-results results

+                   (run-query results))))

+

+(define-it-lookup-command (com-next :name t) ()

+  (let ((results (results *application-frame*)))

+    (incf (it-lookup::page results))

+    (parse-results results

+                   (run-query results))))

+

+(setf mcclim-truetype:*truetype-font-path* "/Library/Fonts/")

+(app-main)

@@ -8,8 +8,9 @@

                 :serapeum

                 :fwoar.lisputils

                 :drakma

-                :lquery)

+                :lquery

+                :climacs-flexichain-output-history

+                )

   :serial t

   :components ((:file "package")

                (:file "it-lookup")))

-

@@ -1,6 +1,7 @@

 ;;;; it-lookup.lisp

 (in-package #:it-lookup)

+(declaim (optimize (debug 3)))

 ;;; "it-lookup" goes here. Hacks and glory await!

@@ -8,18 +9,34 @@

 (defparameter *cookie-jar* (make-instance 'drakma:cookie-jar))

-(defun run-query (query &optional (page 1))

-  (drakma:http-request *post-url*

-                       :method :POST

-                       :parameters `(("text" . ,query)

-                                     ("Form.option.concordances" . "concordances")

-                                     ("results.currentPage" . ,(prin1-to-string page)))

-                       :cookie-jar *cookie-jar*))

+(defun run-query (results)

+  (with-accessors ((query query) (page page)) results

+    (drakma:http-request *post-url*

+                         :method :POST

+                         :parameters `(("text" . ,query)

+                                       ("Form.option.concordances" . "concordances")

+                                       ("results.currentPage" . ,(prin1-to-string page)))

+                         :cookie-jar *cookie-jar*)))

 (defclass it-case ()

   ((reference :initarg :reference :accessor case-reference)

    (text :initarg :text :accessor case-text)))

+(defun make-adjustable-vector (&optional (base-size 10))

+  (make-array base-size :adjustable t :fill-pointer 0))

+

+(defun to-adjustable-vector (values)

+  (let ((els (length values)))

+    (make-array els

+                :adjustable t

+                :fill-pointer els

+                :initial-contents values)))

+

+(defclass it-results ()

+  ((%query :initarg :query :accessor query :initform (make-adjustable-vector))

+   (%page :initarg :page :accessor page :initform 1)

+   (%cases :initarg :cases :accessor cases)))

+

 (defmethod initialize-instance :after ((object it-case) &key)

   (with-slots (reference text) object

     (when (arrayp reference)

@@ -27,8 +44,7 @@

     (when (plump:element-p reference)

       (setf reference (plump-dom:text reference)))

     (setf text (subseq text (+ (search reference text) (length reference))))

-    (setf reference (string-right-trim '(#\space) reference))

-    ))

+    (setf reference (string-right-trim '(#\space) reference))))

 (defmacro make-constructor (class &rest initargs)

   (let ((initarg-syms (mapcar #'(lambda (x) x (gensym)) initargs)))

@@ -38,65 +54,102 @@

                                      nconc (list initarg sym))))))

 (make-constructor it-case :reference :text)

+(make-constructor it-results :query :cases)

+

+(defun parse-results (results query-result)

+  (setf (cases results)

+        (lquery:$ (initialize query-result)

+                  "p[title]"

+                  (:combine ".ref" (text))

+                  (map-apply #'make-it-case))))

-(defun parse-results (query-result)

-  (lquery:$ (initialize query-result) "p[title]" (:combine ".ref" (text)) (map-apply #'make-it-case)))

+(defgeneric format-reference (it-case stream)

+  (:method ((it-case it-case) stream)

+   (princ (case-reference it-case) stream)

+   (fresh-line stream)))

+

+(defparameter *underlying-stream* nil)

+(defun get-real-stream (&optional default)

+  (or *underlying-stream* default))

 (defun format-result (parsed-result &optional (stream t))

-  (with-slots (reference text) parsed-result

+  (let ((real-stream stream))

     (pprint-logical-block (stream nil)

-      (princ reference stream)

+      (let ((*underlying-stream* real-stream))

+        (format-reference parsed-result stream))

       (pprint-indent :block 4 stream)

       (pprint-newline :mandatory stream)

-      (pprint-logical-block (stream (split-sequence #\space text))

-        (loop

-              (princ (pprint-pop) stream)

-              (pprint-exit-if-list-exhausted)

-              (princ #\space stream)

-              (pprint-newline :fill stream))))))

+      (with-slots (text) parsed-result

+        (pprint-logical-block (stream (tokens text))

+          (loop

+            (princ (pprint-pop) stream)

+            (pprint-exit-if-list-exhausted)

+            (princ #\space stream)

+            (pprint-newline :fill stream)))))))

 (defun format-results (parsed-results &optional (stream t))

   (fresh-line stream)

-  (loop :for parsed-results :across parsed-results

-        :do (format-result parsed-results stream)

+  (loop :for parsed-result :across parsed-results

+        :do (format-result parsed-result stream)

         :do (terpri stream)))

 (defmacro compose-funcs ((&rest funcs) &rest args)

   `(funcall (compose ,@funcs) ,@args))

 (defun main (args)

+  (let ((results (make-instance 'it-results

+                                :query nil)))

+

+    (format *terminal-io* "~&Index Thomisticus Query Utility v0.1~%")

+

+    (when (cadr args)

+      (setf (query results) (cadr args)))

+

+    (mainloop results)))

+

+(defun mainloop (results)

   (handler-case

-    (let ((current-page 1)

-          current-query)

-      (flet ((next-page () (incf current-page))

-             (prev-page ()

-               (when (> current-page 0)

-                 (decf current-page)))

-             (get-results (current-query current-page)

-               (compose-funcs (#'format-results #'parse-results #'run-query)

-                              current-query current-page)))

-

-        (format *terminal-io* "~&Index Thomisticus Query Utility v0.1~%")

-

-        (when (cadr args)

-          (setf current-query (string-join (cdr args) #\space))

-          (format *terminal-io* "~&Query: ~a~%" current-query)

-          (get-results current-query current-page))

+      (labels ((next-page () (incf (page results)))

+               (prev-page ()

+                 (with-accessors ((current-page page)) results

+                   (when (> current-page 0)

+                     (decf current-page))))

+               (print-results (results)

+                 (format *terminal-io* "~&Query: ~a, Page: ~3d~%"

+                         (query results)

+                         (page results)))

+               (get-results (results)

+                 (with-accessors ((page page) (query query)) results

+                   (parse-results results

+                                  (run-query results))

+                   (format-results (cases results))))

+               (do-action (action results)

+                 (funcall action)

+                 (get-results results)))

+

         (loop

           (format *terminal-io* "~&Query? ")

           (finish-output *terminal-io*)

-          (let ((action (read-line *terminal-io*)))

+          (let ((action (or (query results)

+                            (read-line *terminal-io*))))

             (string-case action

-              ("quit" (return-from main))

+              ("quit" (return-from mainloop))

+              ("help"

+               (format *terminal-io* "~&Help:~%~:{~4t~a: ~a~%~}~%Anything else searches.~%"

+                       `(("next" "Next page of results")

+                         ("prev" "Previous page of results")

+                         ("quit" "Quits"))))

+

               ("prev"

-               (prev-page)

-               (format *terminal-io* "~&Query: ~a, Page: ~3d~%" current-query current-page)

-               (get-results current-query current-page))      

+               (do-action #'prev-page results))

+

               ("next"

-               (next-page)

-               (format *terminal-io* "~&Query: ~a, Page: ~3d~%" current-query current-page)

-               (get-results current-query current-page))      

-              (t (setf current-query action)

-                 (get-results current-query current-page)))))))

+               (do-action #'next-page results))

+

+              (t (setf (query results)

+                       action)

+                 (get-results results)))

+            (setf (query results) nil))))

+

     (end-of-file (c) (declare (ignore c)))

     (sb-sys:interactive-interrupt (c) (declare (ignore c)))))

@@ -1,5 +1,6 @@

 ;;;; package.lisp

 (defpackage #:it-lookup

-  (:use #:cl #:alexandria #:serapeum #:fwoar.lisputils))

+  (:use #:cl #:alexandria #:serapeum #:fwoar.lisputils)

+  (:export #:format-results #:parse-results #:run-query))