;;;-*- Mode:LISP; Package:HACKS -*- (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:DONT-SELECT-WITH-MOUSE-MIXIN 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 (// (- INSIDE-WIDTH MAGIC-WIDTH) 2)) (OR (PLUSP RECT-LEFT) (FERROR NIL "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 NIL "Window not high enough")) (FUNCALL-SELF ':DRAW-HOLLOW-RECTANGLE RECT-LEFT RECT-TOP RECT-RIGHT RECT-BOTTOM) (FUNCALL-SELF ':DRAW-HOLLOW-RECTANGLE (+ RECT-LEFT RACK-WIDTH) (+ RECT-TOP RACK-WIDTH) (- RECT-RIGHT RACK-WIDTH) (- (+ RECT-TOP MAGIC-MIDDLE-Y) RACK-WIDTH)) (FUNCALL-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) (FUNCALL-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 (// N 10.)) (M DISPLAYED-NUMBER (AND M (// M 10.)))) (( I NBEADS)) (FUNCALL-SELF ':DRAW-BEADS X UPPER-RACK-TOP 2 (LOGXOR (// (\ N 10.) 5) 1) (AND M (LOGXOR (// (\ M 10.) 5) 1))) (FUNCALL-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* ((FIT (FONT-INDEXING-TABLE TV:CURRENT-FONT)) (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) (IF (NULL FIT) (SYS:%DRAW-CHAR TV:CURRENT-FONT CHAR X Y1 TV:CHAR-ALUF SELF) ;;Wide character, draw in segments (DO ((CH (AREF FIT CHAR) (1+ CH)) (LIM (AREF FIT (1+ CHAR))) (BPP (TV:SHEET-BITS-PER-PIXEL SELF)) (X1 X (+ X1 (// (FONT-RASTER-WIDTH TV:CURRENT-FONT) BPP)))) ((= CH LIM)) (SYS:%DRAW-CHAR TV:CURRENT-FONT CH X1 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) (FUNCALL-SELF ':REDISPLAY))) (DEFMETHOD (ABACUS-WINDOW :MOUSE-CLICK) (BUTTON X Y &AUX TEM) (COND ((= BUTTON #\MOUSE-1-1) (IF (SETQ TEM (FUNCALL-SELF ':BEAD-CLICK X Y)) (PROCESS-RUN-FUNCTION "Click" SELF ':SET-CURRENT-NUMBER 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 (// (- 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 (// (- 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 (\ (// CURRENT-NUMBER POWER) 10.)) (NDIGIT (IF TOP-P (+ (\ DIGIT 5) (* 5 (LOGXOR YIDX 1))) (+ (* 5 (// 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 NIL "~S is not a know operation" OPERATION)) (DO ((N NUMBER (// 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)))) (COND (( NEW-NUMBER CURRENT-NUMBER) (DO ((I 0 (1+ I)) (POWER 1 (* POWER 10.)) (DIGIT) (NDIGIT)) (( I NBEADS)) (SETQ DIGIT (\ (// CURRENT-NUMBER POWER) 10.) NDIGIT (\ (// NEW-NUMBER POWER) 10.)) (COND (( DIGIT NDIGIT) (FUNCALL-SELF ':SET-CURRENT-NUMBER (+ (- CURRENT-NUMBER (* POWER DIGIT)) (* POWER NDIGIT))) (AND SLEEP-TIME (PROCESS-SLEEP SLEEP-TIME)))))))) CURRENT-NUMBER) (DEFFLAVOR ABACUS-PANE () (ABACUS-WINDOW TV:PANE-MIXIN)) (DEFFLAVOR ABACUS-FRAME () (TV:BORDERED-CONSTRAINT-FRAME TV:PROCESS-MIXIN)) (DEFFLAVOR ABACUS-LISP-LISTENER-PANE () (TV:PANE-MIXIN TV:DONT-SELECT-WITH-MOUSE-MIXIN TV:NOTIFICATION-MIXIN TV:AUTOEXPOSING-MORE-MIXIN TV:WINDOW)) (DEFMETHOD (ABACUS-FRAME :BEFORE :INIT) (IGNORE) (SETQ TV:SELECTED-PANE 'LISP-WINDOW TV:PROCESS '(ABACUS-PROCESS-TOP-LEVEL :SPECIAL-PDL-SIZE 4000) TV:PANES `((LISP-WINDOW ABACUS-LISP-LISTENER-PANE :LABEL NIL :MORE-P NIL) (ABACUS-WINDOW ABACUS-PANE :LABEL NIL)) TV:CONSTRAINTS '((MAIN . ((ABACUS-WINDOW LISP-WINDOW) ((LISP-WINDOW 0.25s0 :LINES)) ((ABACUS-WINDOW :EVEN))))))) (DEFUN ABACUS-PROCESS-TOP-LEVEL (WINDOW) (DO ((TERMINAL-IO (FUNCALL WINDOW ':GET-PANE 'LISP-WINDOW)) (ABACUS-WINDOW (FUNCALL WINDOW ':GET-PANE 'ABACUS-WINDOW)) (BASE 10.) (IBASE 10.) (CH)) (NIL) (*CATCH 'SYS:COMMAND-LEVEL (PROGN (FORMAT T "~&Type a number or a special character (+, -, = or END) ") (SELECTQ (SETQ CH (FUNCALL STANDARD-INPUT ':TYI)) (#/= (PRINT (FUNCALL ABACUS-WINDOW ':CURRENT-NUMBER))) ((#/+ #/-) (FORMAT T "~&Type a number to ~:[add~;subtract~]: " (= CH #/-)) (LET ((NUMBER (READ))) (AND (NUMBERP NUMBER) (FUNCALL ABACUS-WINDOW ':OPERATE (IF (= CH #/+) '+ '-) NUMBER)))) (#\END (FUNCALL WINDOW ':DESELECT)) (OTHERWISE (FUNCALL STANDARD-INPUT ':UNTYI CH) (LET ((NUMBER (READ))) (AND (NUMBERP NUMBER) (FUNCALL ABACUS-WINDOW ':SET-CURRENT-NUMBER NUMBER))))))))) (DEFVAR *ABACUS-FRAME*) (DEFUN ABACUS () (OR (BOUNDP '*ABACUS-FRAME*) (SETQ *ABACUS-FRAME* (TV:MAKE-WINDOW 'ABACUS-FRAME ':EDGES '(100 100 1200 600)))) (FUNCALL *ABACUS-FRAME* ':SELECT)) (DEFUN ABACUS-DEMO () (ABACUS) (PROCESS-WAIT "Deexpose" #'(LAMBDA (X) (NOT (CAR X))) (LOCF (TV:SHEET-EXPOSED-P *ABACUS-FRAME*)))) (COMPILE-FLAVOR-METHODS ABACUS-WINDOW ABACUS-PANE ABACUS-FRAME ABACUS-LISP-LISTENER-PANE) (DEFDEMO "Abacus" "Upward compatibilty with primitive computers." (ABACUS-DEMO))