Download
(defconst sl-version "0.0.1"
"A sl.el version number string.")
(defconst sl-steam
(list (concat " (@@) ( ) (@) ( ) @@ () @ O @ O @" "\n"
" ( )" "\n"
" (@@@@)" "\n"
" ( )" "\n"
"\n"
" (@@@)" "\n")
(concat " ( ) (@@) ( ) (@) () @@ O @ O @ O" "\n"
" (@@@)" "\n"
" ( )" "\n"
" (@@@@)" "\n"
"\n"
" ( )" "\n")))
(defconst sl-body
(concat
" ==== ________ ___________ " "\n"
" _D _| |_______/ \\__I_I_____===__|_________| " "\n"
" |(_)--- | H\\________/ | | =|___ ___| _________________ " "\n"
" / | | H | | | | ||_| |_|| _| \\_____A " "\n"
" | | | H |__--------------------| [___] | =| | " "\n"
" | ________|___H__/__|_____/[][]~\\_______| | -| | " "\n"
" |/ | |-----------I_____I [][] [] D |=======|____|________________________|_ " "\n"))
(defconst sl-wheel
(list (concat "__/ =| o |=-O=====O=====O=====O \\ ____Y___________|__|__________________________|_ " "\n"
" |/-=|___|= || || || |_____/~\\___/ |_D__D__D_| |_D__D__D_| " "\n"
" \\_/ \\__/ \\__/ \\__/ \\__/ \\_/ \\_/ \\_/ \\_/ \\_/ " "\n")
(concat "__/ =| o |=-~~\\ /~~\\ /~~\\ /~~\\ ____Y___________|__|__________________________|_ " "\n"
" |/-=|___|=O=====O=====O=====O |_____/~\\___/ |_D__D__D_| |_D__D__D_| " "\n"
" \\_/ \\__/ \\__/ \\__/ \\__/ \\_/ \\_/ \\_/ \\_/ \\_/ " "\n")
(concat "__/ =| o |=-~~\\ /~~\\ /~~\\ /~~\\ ____Y___________|__|__________________________|_ " "\n"
" |/-=|___|= || || || |_____/~\\___/ |_D__D__D_| |_D__D__D_| " "\n"
" \\_/ \\O=====O=====O=====O_/ \\_/ \\_/ \\_/ \\_/ \\_/ " "\n")
(concat "__/ =| o |=-~~\\ /~~\\ /~~\\ /~~\\ ____Y___________|__|__________________________|_ " "\n"
" |/-=|___|= || || || |_____/~\\___/ |_D__D__D_| |_D__D__D_| " "\n"
" \\_/ \\_O=====O=====O=====O/ \\_/ \\_/ \\_/ \\_/ \\_/ " "\n")
(concat "__/ =| o |=-~~\\ /~~\\ /~~\\ /~~\\ ____Y___________|__|__________________________|_ " "\n"
" |/-=|___|= O=====O=====O=====O|_____/~\\___/ |_D__D__D_| |_D__D__D_| " "\n"
" \\_/ \\__/ \\__/ \\__/ \\__/ \\_/ \\_/ \\_/ \\_/ \\_/ " "\n")
(concat "__/ =| o |=-~O=====O=====O=====O\\ ____Y___________|__|__________________________|_ " "\n"
" |/-=|___|= || || || |_____/~\\___/ |_D__D__D_| |_D__D__D_| " "\n"
" \\_/ \\__/ \\__/ \\__/ \\__/ \\_/ \\_/ \\_/ \\_/ \\_/ " "\n")))
(defconst sl
(let ((sl-strs))
(dotimes (i (length sl-wheel))
(setq sl-strs (cons (concat (if (> 3 i) (car sl-steam) (cadr sl-steam))
sl-body
(nth i sl-wheel))
sl-strs)))
(nreverse sl-strs)))
(defgroup sl nil
"SL joke program."
:tag "SL"
:group 'sl)
(defcustom sl-face 'sl-face
"*Face for sl."
:type 'face
:group 'sl)
(defcustom sl-place 'center
"*Default displaying place of sl."
:type 'symbol
:group 'sl)
(defcustom sl-speed 100
"*The speed of sl."
:type 'number
:group 'sl)
(defface sl-face
'((((class color)) (:foreground "White" :background "Black" t))
(t (:bold t)))
"A face for sl.")
(defun sl-telop-make (telop-str &optional max-len)
(let* ((telop (split-string telop-str "\n" t))
(max-len (if max-len max-len
(let ((len 0) str-len)
(dolist (i telop)
(setq str-len (string-width i))
(when (> str-len len)
(setq len str-len)))
len)))
str-len lis)
(dolist (i telop)
(setq str-len (string-width i))
(setq lis
(cons (cond
((= str-len max-len)
i)
((> max-len str-len)
(concat i (make-string (- max-len str-len) ? ))))
lis)))
(nreverse lis)))
(defun sl-telops-make (lis)
(let* ((max-str-len (let ((max-len 0) len)
(dolist (i lis)
(setq len (string-width (car (sl-telop-make i))))
(when (> len max-len)
(setq max-len len)))
len))
telops)
(dolist (i lis)
(setq telops (cons (sl-telop-make i max-str-len) telops)))
(nreverse telops)))
(defun sl-telop (str-list &optional face place speed not-inhibit-quit)
(let* ((telops (sl-telops-make str-list))
(telop-height (length (car telops)))
(max-len (length (caar telops)))
(telop-frm (length telops))
(max-width (window-width))
(loops (+ max-width max-len))
(space 0)
(start (window-start))
(face (if face face sl-face))
(wait (/ 1.0 (if speed speed sl-speed)))
(place (if place place 'center))
(inhibit-quit (if not-inhibit-quit nil t))
(truncate-lines t)
(truncate-partial-width-windows t)
last-point telop telop-str overlay)
(save-excursion
(goto-char start)
(cond
((eq place 'top)
(forward-line telop-height))
(t
(forward-line (/ (- (window-height) telop-height) 2))
(setq start (point))))
(setq last-point (point))
(dotimes (i loops)
(setq telop (nth (% i telop-frm) telops)
overlay (make-overlay start last-point)
telop-str
(propertize
(concat
(mapconcat
#'(lambda (x)
(let* (str left right)
(setq str
(cond
((and (>= max-len i) (>= space max-width))
(substring x (- space max-width) max-width))
((>= max-len i) (substring x 0 i))
((>= space max-width)
(substring x (- space max-width)))
(t x))
space
(+ i (- (string-width str) (length str)))
left
(make-string
(cond
((>= space max-width) 0)
((>= max-len i) (- max-width space))
(t (- max-width space)))
? )
right
(make-string
(cond
((>= max-len i) 0)
((>= space max-width)
(- max-width (string-width str)))
(t (- i max-len)))
? ))
(concat left str right)))
telop "\n")
"\n")
'face face))
(unwind-protect (progn
(overlay-put overlay 'after-string telop-str)
(overlay-put overlay 'invisible t)
(sleep-for wait)
(discard-input)
(redisplay))
(when (overlayp overlay)
(delete-overlay overlay)))))
(discard-input)))
(defun sl (&optional face place speed not-inhibit-quit)
(interactive)
(sl-telop sl face place speed not-inhibit-quit))
(provide 'sl)