here's a hack for you

[Steve Strassmann <STRAZ%media-lab.arpa@CSNET-RELAY>]

     --------------------   cut here   --------------------------

;;; -*- Mode: LISP; Base: 10.; Package: (HACKS) -*-
;
; 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 (HACKS:MELT) or do Hyper-M in the editor.
; 
;==============================================================================
;
(defconst 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.")

; Resources let you re-use old arrays instead of consing up new ones.
;
(defresource patch (window width height)
  :constructor (tv:make-sheet-bit-array window width height)
  :matcher (and window
		( (array-dimension-n 1 object) width)
		( (array-dimension-n 2 object) height)))

;==============================================================================
; Install hack in useful places
;
; Install on (HACKS:DEMO)
;
(defdemo "Nuclear Meltdown" "What happens when you drain the freon out of a Cray" (melt))

; Install on Hyper-M in the editor. Numeric argument speeds the meltdown.
; Hyper-super-M melts the wholine.
; Hyper-refresh cleans up the mess.
;
(defun zwei:com-melt ()
  "Gee, Steve, your screen is getting all melty!"
  (melt zwei:*numeric-arg*))

(defun zwei:com-melt-wholine ()
  "Why neglect the wholine?"
  (melt zwei:*numeric-arg* tv:who-line-screen))

(defun zwei:com-refresh-sheet ()
  "Cleans down to the last pixel for a bright, no-wax shine."
  (send tv:main-screen :refresh)
  (send tv:who-line-screen :refresh)
  zwei:dis-none)

(zwei:set-comtab zwei:*standard-comtab*
		 '(#\h-M zwei:com-melt))      		; hyper-M
(zwei:set-comtab zwei:*standard-comtab*
		 '(#\s-h-M zwei:com-melt-wholine))      ; super-hyper-M
(zwei:set-comtab zwei:*standard-comtab*
		 '(#\h-refresh zwei:com-refresh-sheet)) ; hyper-refresh
;==============================================================================

(defun melt (&optional (speed 1) (window tv:main-screen))
  "What happens when you drain the freon out of a Cray"
  (loop with array = (send (send window :screen) :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))
	for top = (and ok? (random bottom))
	for height = (and ok? (- bottom top))
	if ok?
	  do (using-resource (patch patch window width (send window :height))
	       (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 x (1- top)))
		       for smear-bottom = (and smear-top (plusp (aref patch x 0)))
		       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-n 1 array)))

(defun pick-bottom (column array)
  "Pick a white pixel in column to get melted"
  (loop for try from 0
	for y = (1+ (random (1- (array-dimension-n 2 array))))
	for pixel = (aref array column y)
	until (zerop pixel)
	if (= try 5) return 0			; Don't waste your time on this column
	finally (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-n 2 array) 1 bottom))	; Not too far down
	    for pixel = (aref array column (+ bottom drop))
	    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-n 1 array) left))
	for black-pixel? = (loop for y from bottom to (+ bottom drop)
			       for pixel = (aref array x y)
			       if (plusp pixel)
				 do (setq x (1- x))
				    (return t))
	until black-pixel?
	finally (return (- x left))))