melting program for Rel 7.

[Steve Strassmann <straz@think.com>]

Here's a short program for inclusion in the SLUG library.  I think I
sent this out once before; this version will work in Rel 7.1.
 Share and Enjoy,
 Steve Strassmann
 MIT Media Lab / Thinking Machines Corp.

------------------------------------------------------------------------------
;;; -*- Mode: LISP; Base: 10.; Package: (HACKS); Syntax: Common-lisp -*-
;
; 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
;
; Fixed August 14, 1987 for Release 7, in time for the war with Iran,
; by Steve Strassmann.
;
; 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.media.mit.edu.
; 
; To use this file:
;    Call (HACKS:MELT) or do Hyper-M in the editor.
; 
;==============================================================================
(defun array-width (array)
  (array-dimension-n 2 array))

(defun array-height (array)
  (array-dimension-n 1 array))
;==============================================================================
; Install hack in useful places

; 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) (plusp width))
	for top = (and ok? (random bottom))
	for height = (and ok? (- bottom top))
	if ok?
	  do (bitblt tv:alu-seta width (- height)
		     array left top array left (+ drop top))))	; Copy melt portion of screen

(defun pick-column (array)
  "Pick a likely left edge to melt"
  (random (array-width 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-height array))))
	for pixel = (aref array y column)
	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-height array)
						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-width array) left))
	for black-pixel? = (loop for y from bottom to (+ bottom drop)
				 for pixel = (aref array y x)
				 if (plusp pixel)
				   do (return t))
	until black-pixel?
	finally (return (- x left 1))))