From c74934fbe2144c9d409e18fb8fc835b107fedd00 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Thu, 24 Dec 2020 18:03:03 -0800 Subject: [PATCH] Some trouble clonning repo with these files --- internal/test/Maiko/OBSOLETE/Aux/bbtests | 235 ----------------------- 1 file changed, 235 deletions(-) delete mode 100644 internal/test/Maiko/OBSOLETE/Aux/bbtests diff --git a/internal/test/Maiko/OBSOLETE/Aux/bbtests b/internal/test/Maiko/OBSOLETE/Aux/bbtests deleted file mode 100644 index 07609333..00000000 --- a/internal/test/Maiko/OBSOLETE/Aux/bbtests +++ /dev/null @@ -1,235 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(filecreated "24-Jun-88 15:18:43" {eris}malpha>bbtests.\;7 12836 - - |changes| |to:| (functions diagonals simulate-pilotbitblt bump sloped-lines test-diagonals) - (vars bbtestscoms) - - |previous| |date:| "15-Jun-88 19:04:55" {eris}malpha>bbtests.\;2) - - -; Copyright (c) 1988 by Xerox Corporation. All rights reserved. - -(prettycomprint bbtestscoms) - -(rpaqq bbtestscoms ((functions simulate-pilotbitblt bump) - (functions sloped-lines diagonals) - (prop filetype bbtests))) - -(cl:defun simulate-pilotbitblt (bbt) - - (* |;;| "A translation of the algorithm in the Mesa PrincOps.") - - (* |;;| " S-L-O-W !!!") - - (let ((src.word (fetch (pilotbbt pbtsource) of bbt)) - (src.bit (fetch (pilotbbt pbtsourcebit) of bbt)) - (src.bpl (fetch (pilotbbt pbtsourcebpl) of bbt)) - (dst.word (fetch (pilotbbt pbtdest) of bbt)) - (dst.bit (fetch (pilotbbt pbtdestbit) of bbt)) - (dst.bpl (fetch (pilotbbt pbtdestbpl) of bbt)) - (bbt.width (fetch (pilotbbt pbtwidth) of bbt)) - (bbt.height (fetch (pilotbbt pbtheight) of bbt)) - (bool-op (let ((complement? (not (cl:zerop (fetch (pilotbbt pbtsourcetype) of bbt))) - )) - (cl:ecase (fetch (pilotbbt pbtoperation) of bbt) - ((0) (cl:if complement? - cl:boole-c1 - cl:boole-1)) - ((1) (cl:if complement? - cl:boole-andc1 - cl:boole-and)) - ((2) (cl:if complement? - cl:boole-orc1 - cl:boole-ior)) - ((3) (cl:if complement? - cl:boole-eqv - cl:boole-xor))))) - (gray? (fetch (pilotbbt pbtusegray) of bbt)) - (gray.width (itimes (add1 (fetch (pilotbbt pbtgraywidthlessone) of bbt)) - 16)) - (gray.height (add1 (fetch (pilotbbt pbtgrayheightlessone) of bbt))) - line gray.bump last-gray y-forward? x-forward?) - (cl:labels ((modify-bit (dstword dstbit dstoffset srcword srcbit srcoffset) - (cl:multiple-value-bind (srcword srcbit) - (bump srcword srcbit srcoffset) - (cl:multiple-value-bind (dstword dstbit) - (bump dstword dstbit dstoffset) - (cl:setf (ldb (byte 1 (idifference 15 dstbit)) - (getbase dstword 0)) - (cl:boole bool-op (ldb (byte 1 (idifference 15 srcbit - )) - (getbase srcword 0)) - (ldb (byte 1 (idifference 15 dstbit)) - (getbase dstword 0))))))) - (bitblt-item nil - (let ((offset (cl:if x-forward? - 0 - (sub1 bbt.width)))) - (frptq bbt.width - (let ((pos (cl:if gray? - (idifference (imod (iplus offset src.bit) - (abs gray.width)) - src.bit) - offset))) - (modify-bit dst.word dst.bit offset src.word src.bit pos) - ) - (cl:incf offset (cl:if x-forward? - 1 - -1))))) - (setup nil (cl:when gray? - (setq gray.bump (iminus (itimes gray.width (sub1 gray.height))))) - (compute-direction) - (cl:when gray? - (setq last-gray (cl:if y-forward? - (idifference gray.height 1 (fetch (pilotbbt - - pbtgrayoffset - ) - of bbt)) - (fetch (pilotbbt pbtgrayoffset) of bbt)))) - (setq line (cl:if y-forward? - 0 - (sub1 bbt.height)))) - (compute-direction nil (setq y-forward? (setq x-forward? - (not (fetch (pilotbbt pbtbackward) - of bbt)))))) - (setup) - (while (and (ileq 0 line) - (ilessp line bbt.height)) - do (bitblt-item) - (block) (* \; "just to be nice.") - (cl:multiple-value-setq (src.word src.bit) - (bump src.word src.bit (cl:if gray? - (cl:if (= (imod line gray.height) - last-gray) - gray.bump - gray.width) - src.bpl))) - (cl:multiple-value-setq (dst.word dst.bit) - (bump dst.word dst.bit dst.bpl)) - (cl:incf line (cl:if y-forward? - 1 - -1)))))) - -(cl:defun bump (word bit incr) - (cl:multiple-value-bind (word-incr new-bit) - (cl:floor (iplus bit incr) - 16) - (cl:values (addbase word word-incr) - new-bit))) - -(cl:defun sloped-lines (w) - (let* ((feedback-interval (quotient w 20)) - (next-feedback 0) - (black #16*1) - (a (cl:make-array (list w w) - :element-type - 'bit :initial-element 0)) - (da (cl:make-array (itimes w w) - :element-type - 'bit :displaced-to a)) - (r (cl:make-array (list w w) - :element-type - 'bit :initial-element 0)) - (dr (cl:make-array (itimes w w) - :element-type - 'bit :displaced-to r)) - (bbt (create pilotbbt - pbtdest _ (fetch (array-header base) of a) - pbtdestbit _ 0 - pbtsource _ (fetch (array-header base) of black) - pbtsourcebit _ 0 - pbtgrayoffset _ 0 - pbtgraywidthlessone _ 0 - pbtgrayheightlessone _ 0 - pbtwidth _ 0 - pbtdisjoint _ t - pbtusegray _ t))) - (cl:dotimes (slope w) - (cl:when (> slope next-feedback) - (cl:princ #\. *error-output*) - (cl:incf next-feedback feedback-interval)) - (cl:fill da 0) - (replace (pilotbbt pbtdestbpl) of bbt with (iplus w slope 1)) - (cl:incf (fetch (pilotbbt pbtwidth) of bbt)) - (replace (pilotbbt pbtheight) of bbt with (cl:ceiling w (add1 slope))) - (\\pilotbitblt bbt nil) - (cl:fill dr 0) - (simulate-pilotbitblt (create pilotbbt using bbt pbtdest _ (fetch - (array-header base) - of r))) - (cl:when (not (cl:equal da dr)) - (cl:cerror "Try the next one" "Bad BITBLT: diagonal w: ~D slope: ~D" w slope))))) - -(cl:defun diagonals (w) - - (* |;;| "Draw both diagonals in a square of size W.") - - (let* ((failures nil) - (black #16*1) - (a (cl:make-array (list w w) - :element-type - 'bit :initial-element 0)) - (a-base (fetch (array-header base) of a)) - (da (cl:make-array (itimes w w) - :element-type - 'bit :displaced-to a)) - (r (cl:make-array (list w w) - :element-type - 'bit :initial-element 0)) - (r-base (fetch (array-header base) of r)) - (dr (cl:make-array (itimes w w) - :element-type - 'bit :displaced-to r)) - (bbt (create pilotbbt - pbtsource _ (fetch (array-header base) of black) - pbtsourcebit _ 0 - pbtgrayoffset _ 0 - pbtgraywidthlessone _ 0 - pbtgrayheightlessone _ 0 - pbtwidth _ 1 - pbtheight _ w - pbtdisjoint _ t - pbtusegray _ t))) - (cl:macrolet ((clear (which) - `(cl:fill ,which 0))) - (cl:labels ((set-source (bbt base increment) - (cl:multiple-value-bind (word bit) - (bump base 0 increment) - (replace (pilotbbt pbtdest) of bbt with word) - (replace (pilotbbt pbtdestbit) of bbt with - bit)) - bbt) - (check-result (from to start-offset) - (clear dr) - (simulate-pilotbitblt (set-source (create pilotbbt - using bbt) - r-base start-offset)) - (cl:when (not (cl:equal da dr)) - (cl:push (cl:concatenate 'string from " to " to) - failures) - (cl:cerror "Try the next one" - "Bad BITBLT: ~A to ~A diagonal w: ~D " from to w))) - (do-one (from to start-offset bpl) - (clear da) - (replace (pilotbbt pbtdestbpl) of bbt with bpl) - (replace (pilotbbt pbtbackward) of bbt - with (ilessp bpl 0)) - (\\pilotbitblt (set-source bbt a-base start-offset) - nil) - (check-result from to start-offset))) - (do-one "upper left" "lower right" 0 (add1 w)) - (do-one "upper right" "lower left" (sub1 w) - (sub1 w)) - (do-one "lower left" "upper right" (itimes w (sub1 w)) - (iminus (sub1 w))) - (do-one "lower right" "upper left" (sub1 (itimes w w)) - (iminus (add1 w))))) - (cl:values (not failures) - failures))) - -(putprops bbtests filetype :compile-file) -(putprops bbtests copyright ("Xerox Corporation" 1988)) -(declare\: dontcopy - (filemap (nil))) -stop