Some trouble clonning repo with these files
This commit is contained in:
Larry Masinter
@@ -1,235 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
(filecreated "24-Jun-88 15:18:43" {eris}<daniels>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}<daniels>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
|
||||
Reference in New Issue
Block a user