;
; sl.l: an sl clone for xyzzy
;
; Dec 14, 2011 by FUJIWARA Teruyoshi
;
; Copyright:
;   Copyright (c) 1993,1998 Toyoda Masashi
;   Copyright (c) 2011 FUJIWARA Teruyoshi
;
; License:
;   ASCII art in this script is derived from sl and is under
;   the same terms as sl.
;   (You can get the original sl at http://www.tkl.iis.u-tokyo.ac.jp/~toyoda/sl/sl.tar)
; 
;   Other part is under the same terms as xyzzy.
;
; Installation:
;   1. Copy this file into /path/to/xyzzy/site-lisp.
;   2. Add "(load-library "sl") in your .xyzzy.
;   3. (optional) Add "(global-set-key '(#\M-s #\l) 'sl)" in your .xyzzy.
;   4. (optional) Byte compile makes these functions faster.
;
; Usage:
;   M-x sl (or M-s l)
;

(defvar *sl-buffer-name* "*sl*")

(defvar d51str '("      ====        ________                ___________ "
               "  _D _|  |_______/        \\__I_I_____===__|_________| "
               "   |(_)---  |   H\\________/ |   |        =|___ ___|   "
               "   /     |  |   H  |  |     |   |         ||_| |_||   "
               "  |      |  |   H  |__--------------------| [___] |   "
               "  | ________|___H__/__|_____/[][]~\\_______|       |   "
               "  |/ |   |-----------I_____I [][] []  D   |=======|__ "))

(defvar d51whl '(("__/ =| o |=-~~\\  /~~\\  /~~\\  /~~\\ ____Y___________|__ "
									" |/-=|___|=    ||    ||    ||    |_____/~\\___/        "
									"  \\_/      \\_O=====O=====O=====O/      \\_/            ")
								 ("__/ =| o |=-~~\\  /~~\\  /~~\\  /~~\\ ____Y___________|__ "
									" |/-=|___|=   O=====O=====O=====O|_____/~\\___/        "
									"  \\_/      \\__/  \\__/  \\__/  \\__/      \\_/            ")
								 ("__/ =| o |=-~O=====O=====O=====O\\ ____Y___________|__ "
									" |/-=|___|=    ||    ||    ||    |_____/~\\___/        "
									"  \\_/      \\__/  \\__/  \\__/  \\__/      \\_/            ")
								 ("__/ =| o |=-O=====O=====O=====O \\ ____Y___________|__ "
									" |/-=|___|=    ||    ||    ||    |_____/~\\___/        "
									"  \\_/      \\__/  \\__/  \\__/  \\__/      \\_/            ")
								 ("__/ =| o |=-~~\\  /~~\\  /~~\\  /~~\\ ____Y___________|__ "
									" |/-=|___|=O=====O=====O=====O   |_____/~\\___/        "
									"  \\_/      \\__/  \\__/  \\__/  \\__/      \\_/            ")
								 ("__/ =| o |=-~~\\  /~~\\  /~~\\  /~~\\ ____Y___________|__ "
									" |/-=|___|=    ||    ||    ||    |_____/~\\___/        "
									"  \\_/      \\O=====O=====O=====O_/      \\_/            ")))

(defvar coal-upper '("                              "
									 "                              "
									 "    _________________         "
									 "   _|                \\_____A  "
									 " =|                        |  "
									 " -|                        |  "
									 "__|________________________|_ "))

(defvar coal-under '("|__________________________|_ "
									 "   |_D__D__D_|  |_D__D__D_|   "
									 "    \\_/   \\_/    \\_/   \\_/    "))

(defvar smoke '(("                       (  ) (@@) ( )  (@)  ()    @@    O     @     O     @      O   "
							 "                  (@@@)                                                             "
							 "              (    )                                                                "
							 "           (@@@@)                                                                   "
							 "                                                                                    "
							 "         (   )                                                                      ")
							
							("                       (@@) (  ) (@)  ( )  @@    ()    @     O     @     O      @   "
							 "                  (   )                                                             "
							 "              (@@@@)                                                                "
							 "           (    )                                                                   "
							 "                                                                                    "
							 "         (@@@)                                                                      ")))

(defvar train-length 83)

(defun repeat-string (str n)
	(if (= n 0)
			""
		(concat str (repeat-string str (1- n)))))

(defun fit-line-string (pos str)
	(let ((line (concat (repeat-string " " pos) str))
				(width (window-columns)))
		(if (> (length line) width)
				(subseq line 0 (1- (window-columns)))
			line)))

(defun gen-smoke (pos)
	(nth (truncate (mod pos 8) 4) smoke))

(defun display-d51 (pos frame)
	(labels ((insert-head (s1 s2)
						 (insert (fit-line-string pos (concat s1 s2)) "\n"))
					 (insert-tail (s1 s2)
						 (insert (subseq (concat s1 s2) (* pos -1)) "\n")))
		(cond ((>= pos 0)
					 (dolist (s (gen-smoke pos))
						 (insert (fit-line-string pos s) "\n"))
					 (mapcar #'insert-head
									 d51str
									 coal-upper)
					 (mapcar #'insert-head
									 (nth (mod frame (length d51whl)) d51whl)
									 coal-under))
					((< pos 0)
					 (dolist (s (gen-smoke pos))
						 (insert (subseq s (* pos -1)) "\n"))
					 (mapcar #'insert-tail
									 d51str
									 coal-upper)
					 (mapcar #'insert-tail
									 (nth (mod frame (length d51whl)) d51whl)
									 coal-under)))))

(defun animate (pos frame)
	(cond ((>= pos (* -1 train-length))
				 (delete-region (point-min) (point-max))
				 (display-d51 pos frame)
				 (sleep-for 0.025)
				 (sit-for 0.0001)
				 (animate (1- pos) (1+ frame)))))

(defun sl ()
	(interactive)
	(save-excursion
		(let ((buf (switch-to-buffer *sl-buffer-name*)))
			(set-local-window-flags buf
															(+ *window-flag-newline*
																 *window-flag-eof*)
															nil)
			(animate (window-columns) 0)
			(sit-for 1)
			(delete-buffer *sl-buffer-name*))))