LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032648. :SYSTEM-TYPE :LOGICAL :VERSION 3. :TYPE "LISP" :NAME "MELT" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "GRAPHICS-DEMO") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2754394036. :AUTHOR "REL3" :LENGTH-IN-BYTES 3727. :LENGTH-IN-BLOCKS 4. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                     ;;; -*- Mode:Common-Lisp; Package:DEMO; Base:10 -*-;; Nuclear meltdown;; Written while waiting for some Chinese take-out dinner; on March 23, 1986, when the US started a war with Libya.; by Steve Strassmann, MIT Media Lab;; Inspired by a similar hack on the Apple Macintosh, and by Our President.; Permission is granted for redistribution as long as this header is retained; in its entirety.; Send fan mail to straz@media-lab.mit.edu.; ; To use this file:;    Call (DEMO:MELT) or do Hyper-M in the editor.; ;;;; hacked for Explorer by HQM (did you know that their screen arrays;; are indexed (aref array y x)??);;;==============================================================================;(defparameter tv:black (tv:make-sheet-bit-array tv:initial-lisp-listener 32 1 :initial-value 1)  "An array of 1's which can be BITBLTed to the main screen. This beats DRAW-RECTANGLE.")(defparameter patch (tv:make-sheet-bit-array tv:main-screen tv:main-screen-width tv:main-screen-height));==============================================================================;==============================================================================(defun melt (&optional (speed 1) (window tv:main-screen))  "What happens when you drain the freon out of a Cray"  (loop with array = (send window :screen-array)for left = (pick-column array)for bottom = (pick-bottom left array)for drop = (pick-drop left bottom speed array)for width = (pick-width left bottom drop array)for ok? = (and (plusp bottom) (plusp drop) (plusp width))for top = (and ok? (random bottom))for height = (and ok? (- bottom top))if ok?  do (progn       (bitblt tv:alu-seta width height array left top patch 0 0); Copy melt portion of screen to patch       (bitblt tv:alu-seta width height patch 0 0 array left (+ drop top)); Copy from patch to new location       (bitblt tv:alu-andca width drop tv:black 0 0 array left top); Fill gap with whitespace               ;; Smear fills gap with black if line above dropped region is black       (when (plusp top); Don't smear if top=0 (loop for x from left       repeat width       for smear-top = (plusp (aref array (1- top) x))       for smear-bottom = (and smear-top (plusp (aref patch 0 x)))       for smear-length = (cond ((and smear-top (= drop 1)) 1)(smear-bottom drop)(smear-top drop)(t nil))       do (when smear-length    (bitblt tv:alu-seta 1 smear-length tv:black 0 0 array x top)))))))(defun pick-column (array)  "Pick a likely left edge to melt"  (random (array-dimension array 1)))(defun pick-bottom (column array)  "Pick a white pixel in column to get melted"  (loop for try from 0for y = (1+ (random (1- (array-dimension array 0))))for pixel = (aref array y column)until (zerop pixel)if (= try 5) return 0; Don't waste your time on this columnfinally (return y))); Found a good bottom(defun pick-drop (column bottom speed array)  "Pick how far to drop melted column"  (if (< bottom 2) 1      (loop for drop from 0 below (min speed (- (array-dimension array 0) 1 bottom)); Not too far down    for pixel = (aref array (+ bottom drop) column)    until (plusp pixel)    finally (return drop))))(defun pick-width (left bottom drop array)  "Move rightwards until you hit a black pixel"  (loop for x from left to (random (- (array-dimension array 1) left))for black-pixel? = (loop for y from bottom to (+ bottom drop)       for pixel = (aref array y x)       if (plusp pixel) do (setq x (1- x))    (return t))until black-pixel?finally (return (- x left))))(DEFDEMO "Melt" "My ssccrreeeenn iiisss rrrruuuunnnnnnnniiiinnnnggg!!!!" (melt))UMBER-HEIGHT)))((ZEROP BITS))      (AND (zlc:BIT-TEST 1 BITS)   (SYS:%DRAW-RECTANGLE 6 (- CARD-NUMBER-HEIGHT 3) X YTV:ALU-IOR CARD-WINDOW)))))(DEFUN ERASE-CARD-CHAR (CHAR CHAR-X &AUX X BITS)  (TV:PREPARE-SHEET (CARD-WINDOW)    (SETQ X (+ CARD-MARGIN 2 (* CHAR-X 9)))    (SYS:%DRAW-RECTANGLE 5 10. X (+ CARD-TOP CARD-LETTER-TOP) TV:ALU-ANDCA CARD-WIND