;;;-*- Mode:LISP; Package:HACKS; Base:8; Readtable:ZL -*- (DEFFLAVOR ABACUS-WINDOW ((NBEADS 10.) (BEAD-MARGIN-WIDTH 4.) (RACK-WIDTH 8.) (CURRENT-NUMBER 0) DISPLAYED-NUMBER RACK-LEFT UPPER-RACK-TOP LOWER-RACK-TOP ) (TV:WINDOW) (:DEFAULT-INIT-PLIST :FONT-MAP '(FONTS:ABACUS) :BLINKER-P NIL :MORE-P NIL) (:INITABLE-INSTANCE-VARIABLES NBEADS BEAD-MARGIN-WIDTH RACK-WIDTH CURRENT-NUMBER) (:GETTABLE-INSTANCE-VARIABLES CURRENT-NUMBER)) (DEFMETHOD (ABACUS-WINDOW :AFTER :REFRESH) (&OPTIONAL IGNORE) (OR TV:RESTORED-BITS-P (LET ((INSIDE-LEFT (TV:SHEET-INSIDE-LEFT)) (INSIDE-TOP (TV:SHEET-INSIDE-TOP)) (INSIDE-RIGHT (TV:SHEET-INSIDE-RIGHT)) (INSIDE-BOTTOM (TV:SHEET-INSIDE-BOTTOM)) (BEAD-WIDTH (FONT-CHAR-WIDTH TV:CURRENT-FONT)) (BEAD-HEIGHT (FONT-CHAR-HEIGHT TV:CURRENT-FONT))) (LET ((INSIDE-WIDTH (- INSIDE-RIGHT INSIDE-LEFT)) (MAGIC-WIDTH (+ (* NBEADS BEAD-WIDTH) (* (1+ NBEADS) BEAD-MARGIN-WIDTH) (* 2 RACK-WIDTH))) (MAGIC-HEIGHT (+ (* BEAD-HEIGHT (+ 2 5)) (* 3 RACK-WIDTH) 4)) (MAGIC-MIDDLE-Y (+ (* BEAD-HEIGHT 2) (* 2 RACK-WIDTH) 2)) RECT-LEFT RECT-TOP RECT-RIGHT RECT-BOTTOM) (SETQ RECT-LEFT (TRUNCATE (- INSIDE-WIDTH MAGIC-WIDTH) 2)) (OR (PLUSP RECT-LEFT) (FERROR "Window not wide enough")) (SETQ RECT-TOP (+ INSIDE-TOP RECT-LEFT) RECT-LEFT (+ INSIDE-LEFT RECT-LEFT)) (SETQ RECT-RIGHT (+ RECT-LEFT MAGIC-WIDTH)) (SETQ RECT-BOTTOM (+ RECT-TOP MAGIC-HEIGHT)) (OR (< RECT-BOTTOM INSIDE-BOTTOM) (FERROR "Window not high enough")) (SEND SELF :DRAW-HOLLOW-RECTANGLE RECT-LEFT RECT-TOP RECT-RIGHT RECT-BOTTOM) (SEND SELF :DRAW-HOLLOW-RECTANGLE (+ RECT-LEFT RACK-WIDTH) (+ RECT-TOP RACK-WIDTH) (- RECT-RIGHT RACK-WIDTH) (- (+ RECT-TOP MAGIC-MIDDLE-Y) RACK-WIDTH)) (SEND SELF :DRAW-HOLLOW-RECTANGLE (+ RECT-LEFT RACK-WIDTH) (+ RECT-TOP MAGIC-MIDDLE-Y) (- RECT-RIGHT RACK-WIDTH) (- RECT-BOTTOM RACK-WIDTH)) (SETQ RACK-LEFT (+ RECT-LEFT RACK-WIDTH 1) UPPER-RACK-TOP (+ RECT-TOP RACK-WIDTH 1)) (SETQ LOWER-RACK-TOP (+ RECT-TOP MAGIC-MIDDLE-Y 1)) (SETQ DISPLAYED-NUMBER NIL) (SEND SELF :REDISPLAY))))) (DEFMETHOD (ABACUS-WINDOW :DRAW-HOLLOW-RECTANGLE) (LEFT TOP RIGHT BOTTOM) (TV:PREPARE-SHEET (SELF) (SYS:%DRAW-LINE LEFT TOP RIGHT TOP TV:CHAR-ALUF NIL SELF) (SYS:%DRAW-LINE (1- RIGHT) TOP (1- RIGHT) BOTTOM TV:CHAR-ALUF NIL SELF) (SYS:%DRAW-LINE (1- RIGHT) (1- BOTTOM) LEFT (1- BOTTOM) TV:CHAR-ALUF NIL SELF) (SYS:%DRAW-LINE LEFT TOP LEFT BOTTOM TV:CHAR-ALUF NIL SELF))) (DEFMETHOD (ABACUS-WINDOW :REDISPLAY) (&AUX BEAD-WIDTH) (SETQ BEAD-WIDTH (+ BEAD-MARGIN-WIDTH (FONT-CHAR-WIDTH TV:CURRENT-FONT))) (DO ((I 0 (1+ I)) (X (+ RACK-LEFT BEAD-MARGIN-WIDTH (* (1- NBEADS) BEAD-WIDTH)) (- X BEAD-WIDTH)) (N CURRENT-NUMBER (TRUNCATE N 10.)) (M DISPLAYED-NUMBER (AND M (TRUNCATE M 10.)))) (( I NBEADS)) (SEND SELF :DRAW-BEADS X UPPER-RACK-TOP 2 (LOGXOR (TRUNCATE (\ N 10.) 5) 1) (AND M (LOGXOR (TRUNCATE (\ M 10.) 5) 1))) (SEND SELF :DRAW-BEADS X LOWER-RACK-TOP 5 (\ N 5) (AND M (\ M 5)))) (SETQ DISPLAYED-NUMBER CURRENT-NUMBER)) (DEFMETHOD (ABACUS-WINDOW :DRAW-BEADS) (X Y NHIGH VAL OVAL) (OR (EQ VAL OVAL) (TV:PREPARE-SHEET (SELF) (LET* ((BEAD-WIDTH (FONT-CHAR-WIDTH TV:CURRENT-FONT)) (BEAD-HEIGHT (FONT-CHAR-HEIGHT TV:CURRENT-FONT)) (LEN (LSH 1 NHIGH)) (ALLBITS (1- LEN)) (BITS (LOGXOR ALLBITS (LSH LEN (- (1+ VAL))))) (OBITS (IF OVAL (LOGXOR ALLBITS (LSH LEN (- (1+ OVAL)))) (LOGXOR BITS ALLBITS)))) (DO ((I 0 (1+ I)) (Y1 Y (+ Y1 BEAD-HEIGHT)) (MASK (LOGXOR BITS OBITS)) (PPSS (DPB (1- NHIGH) 0606 0001) (- PPSS 0100))) (( I NHIGH)) (AND (LDB-TEST PPSS MASK) (LET ((CHAR (IF (LDB-TEST PPSS BITS) #/B #/A))) (SYS:%DRAW-RECTANGLE BEAD-WIDTH BEAD-HEIGHT X Y1 TV:ERASE-ALUF SELF) (TV#:DRAW-CHAR TV:CURRENT-FONT CHAR X Y1 TV:CHAR-ALUF SELF)))))))) (DEFMETHOD (ABACUS-WINDOW :SET-CURRENT-NUMBER) (NEW-NUMBER) (LET ((MAX (^ 10. NBEADS))) (SETQ NEW-NUMBER (\ NEW-NUMBER MAX)) (AND (MINUSP NEW-NUMBER) (SETQ NEW-NUMBER (+ MAX NEW-NUMBER)))) (SETQ CURRENT-NUMBER NEW-NUMBER) (TV:SHEET-FORCE-ACCESS (SELF) (SEND SELF :REDISPLAY))) (DEFMETHOD (ABACUS-WINDOW :MOUSE-CLICK) (BUTTON X Y &AUX TEM) (WHEN (= BUTTON #\MOUSE-1-1) (IF (SETQ TEM (SEND SELF :BEAD-CLICK X Y)) (PROCESS-RUN-FUNCTION "Click" (LAMBDA (S N) (SEND S :SET-CURRENT-NUMBER N)) SELF TEM) (BEEP)) T)) (DEFMETHOD (ABACUS-WINDOW :BEAD-CLICK) (X Y &AUX BEAD-WIDTH BEAD-HEIGHT) (SETQ BEAD-WIDTH (FONT-CHAR-WIDTH TV:CURRENT-FONT) BEAD-HEIGHT (FONT-CHAR-HEIGHT TV:CURRENT-FONT)) (LET ((XIDX (TRUNCATE (- X (+ RACK-LEFT BEAD-MARGIN-WIDTH)) (+ BEAD-WIDTH BEAD-MARGIN-WIDTH)))) (AND ( XIDX 0) (< XIDX NBEADS) (< X (+ RACK-LEFT BEAD-MARGIN-WIDTH (* XIDX (+ BEAD-WIDTH BEAD-MARGIN-WIDTH)) BEAD-WIDTH)) (LET* ((TOP-P (< Y LOWER-RACK-TOP)) (YIDX (TRUNCATE (- Y (IF TOP-P UPPER-RACK-TOP LOWER-RACK-TOP)) BEAD-HEIGHT))) (AND ( YIDX 0) (< YIDX (IF TOP-P 2 5)) (LET* ((POWER (^ 10. (- NBEADS XIDX 1))) (DIGIT (\ (TRUNCATE CURRENT-NUMBER POWER) 10.)) (NDIGIT (IF TOP-P (+ (\ DIGIT 5) (* 5 (LOGXOR YIDX 1))) (+ (* 5 (TRUNCATE DIGIT 5)) YIDX)))) (AND ( DIGIT NDIGIT) (+ (- CURRENT-NUMBER (* POWER DIGIT)) (* POWER NDIGIT))))))))) (DEFMETHOD (ABACUS-WINDOW :OPERATE) (OPERATION NUMBER &OPTIONAL (SLEEP-TIME 30.)) (OR (MEMQ OPERATION '(- +)) (FERROR "~S is not a known operation" OPERATION)) (DO ((N NUMBER (TRUNCATE N 10.)) (POWER 1 (* POWER 10.)) (NEW-NUMBER)) ((ZEROP N)) (SETQ NEW-NUMBER (FUNCALL OPERATION CURRENT-NUMBER (* (\ N 10.) POWER))) (LET ((MAX (^ 10. NBEADS))) (SETQ NEW-NUMBER (\ NEW-NUMBER MAX)) (AND (MINUSP NEW-NUMBER) (SETQ NEW-NUMBER (+ MAX NEW-NUMBER)))) (UNLESS (= NEW-NUMBER CURRENT-NUMBER) (DO ((I 0 (1+ I)) (POWER 1 (* POWER 10.)) (DIGIT) (NDIGIT)) (( I NBEADS)) (SETQ DIGIT (\ (TRUNCATE CURRENT-NUMBER POWER) 10.) NDIGIT (\ (TRUNCATE NEW-NUMBER POWER) 10.)) (UNLESS (= DIGIT NDIGIT) (SEND SELF :SET-CURRENT-NUMBER (+ (- CURRENT-NUMBER (* POWER DIGIT)) (* POWER NDIGIT))) (AND SLEEP-TIME (PROCESS-SLEEP SLEEP-TIME)))))) CURRENT-NUMBER) (DEFFLAVOR ABACUS-FRAME () (TV:FRAME-DONT-SELECT-INFERIORS-WITH-MOUSE-MIXIN TV:BORDERED-CONSTRAINT-FRAME TV:PROCESS-MIXIN)) (DEFMETHOD (ABACUS-FRAME :NAME-FOR-SELECTION) () TV:NAME) (DEFCONST ABACUS-LABEL "[END]: exit =: print +: add -: subtract digits: set number") (DEFMETHOD (ABACUS-FRAME :BEFORE :INIT) (IGNORE) (SETQ TV:PROCESS '(ABACUS-PROCESS-TOP-LEVEL :SPECIAL-PDL-SIZE 4000) TV:PANES `((LISP-WINDOW TV:INTERACTION-PANE :LABEL NIL :MORE-P NIL) (ABACUS-WINDOW ABACUS-WINDOW :LABEL ,ABACUS-LABEL)) TV:CONSTRAINTS '((MAIN . ((ABACUS-WINDOW LISP-WINDOW) ((LISP-WINDOW 0.25s0 :LINES)) ((ABACUS-WINDOW :EVEN))))))) (DEFMETHOD (ABACUS-FRAME :AFTER :INIT) (IGNORE) (SEND SELF :SELECT-PANE (SEND SELF :GET-PANE 'LISP-WINDOW))) (DEFUN ABACUS-PROCESS-TOP-LEVEL (WINDOW) (DO* ((*TERMINAL-IO* (SEND WINDOW :GET-PANE 'LISP-WINDOW)) (*STANDARD-OUTPUT* *TERMINAL-IO*) (ABACUS-WINDOW (SEND WINDOW :GET-PANE 'ABACUS-WINDOW)) (*READ-BASE* 10.) (*PRINT-BASE* 10.) (CH)) (NIL) (SEND ABACUS-WINDOW :SET-LABEL ABACUS-LABEL) (CATCH-ERROR-RESTART ((SYS:ABORT EH:DEBUGGER-CONDITION) "Return to ABACUS command level.") (PROGN (CASE (SETQ CH (SEND *STANDARD-INPUT* :READ-CHAR)) (#/= (FORMAT T "= ~D~%" (SEND ABACUS-WINDOW :CURRENT-NUMBER))) ((#/+ #/-) (SEND ABACUS-WINDOW :SET-LABEL (FORMAT NIL "Type a number to ~:[add~;subtract~]. End with Space or Return." (EQ CH #/-))) (WRITE-CHAR CH) (LET ((NUMBER (READ))) (AND (NUMBERP NUMBER) (SEND ABACUS-WINDOW :OPERATE (IF (EQ CH #/+) '+ '-) NUMBER)))) (#/END (SEND WINDOW :DESELECT)) (OTHERWISE (IF (DIGIT-CHAR-P CH) (PROGN (SEND *STANDARD-INPUT* :UNREAD-CHAR CH) (SEND ABACUS-WINDOW :SET-LABEL "Type a number to store in the abacus. End with Space or Return.") (LET ((NUMBER (READ))) (AND (NUMBERP NUMBER) (SEND ABACUS-WINDOW :SET-CURRENT-NUMBER NUMBER)))) (TV:BEEP)))))))) (DEFVAR *ABACUS-FRAME*) (DEFUN ABACUS () (OR (BOUNDP '*ABACUS-FRAME*) (SETQ *ABACUS-FRAME* (MAKE-INSTANCE 'ABACUS-FRAME :EDGES '(64. 64. 640. 450.)))) (SEND *ABACUS-FRAME* :SELECT)) (DEFUN ABACUS-DEMO () (ABACUS) (PROCESS-WAIT "Deexpose" (LAMBDA (X) (NULL (CONTENTS X))) (LOCF (TV:SHEET-EXPOSED-P *ABACUS-FRAME*)))) (COMPILE-FLAVOR-METHODS ABACUS-WINDOW ABACUS-FRAME) (DEFDEMO "Abacus" "Upward compatibilty with primitive computers." (ABACUS-DEMO))