;;; spiral.el --- write string spirally
;; Copyright (c) 2005
;;   by HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
;; $Id: spiral.el,v 1.8 2005/06/02 12:57:55 hira Exp $
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 1, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; The GNU General Public License is available by anonymouse ftp from
;; prep.ai.mit.edu in pub/gnu/COPYING.  Alternately, you can write to
;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
;; USA.
;;--------------------------------------------------------------------

;;; Commentary:

;;        Type+M-             I
;;              x             t
;;   ut+an+arbi +     dea+is+ s
;;   p        t s     i     g +
;;   ni+dna+larip     +lanigiro
;;            a             v
;; ite+it+sp  r    +Keii    e
;; r       i  y    o   c    n
;; w+ot+gnirts+    nakihS+yb+
;;         a           i
;;         lly.        rou.Thanks.
;; 
;; http://k16journal.blogspot.com/2005/05/blog-post_21.html (in Japanese)

;; You can find the latest version at <http://howm.sourceforge.jp/a/spiral.el>

;; ChangeLog
;; [2005-06-02] fix collapsed result when indent-tabs-mode is non-nil.
;; thx > Shikano san <k16.shikano@gmail.com>
;; [2005-05-27] first version

;; Sample in Japanese:
;; <http://howm.sourceforge.jp/cgi-bin/hiki/hiki.cgi?SpiralDotEl>
;; 
;; 　　　　　　　　　　　　　　　　とりあえず
;; 　　　　　　　　　　　　　　　　　　　　で
;; 　　　　からちゃんとうごくかどうか…や　っ
;; 　　　　だ　　　　　　　　　　　　　っ　ち
;; 　　　　んげかいいくごすどけたしまみてげあ
;; 　　　　　　　　　　　　　　　　　　い
;; うほのなかからどれをえらぶ　　　　　る
;; こ　　　　　　　　　　　か　　　　　こ
;; のうすくふ。くさんたんぜのりごりごはと
;; 　　　　　　　　　　　　ひ
;; 　とくふうし　　　　　　ょ
;; 　っ　　　た　　　　　　う
;; 　も、はていつにんゅじきか
;; 　　　　　と
;; 　　　　　ころです。
;; 
;; 日本語の場合は、こんな設定をしておくとよいかも
;; (setq spiral-replace '(("  " . "　")))  ;; 全角空白におきかえ
;; (setq spiral-taboo "+-., 。、")  ;; これらの文字で交叉してもつまらない

;;; Code:

;; I know this is evil. Patches are welcome :-p
(require 'cl)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; var

(defvar spiral-taboo "+-., ")
(defvar spiral-replace nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; command

(defun spiral (str)
  (interactive "sString: ")
  (let ((start-col 100)
        (buf-name "*spiral*"))
    (let* ((lis (spiral-string-to-list str))
           (loops (spiral-best-loop (spiral-matched-pairs lis 8 6) 6)))
      (switch-to-buffer (generate-new-buffer buf-name))
      (setq indent-tabs-mode nil) ;; buffer local
      ;; write in picture-mode
      (picture-mode)
      (picture-movement-right)
      (picture-motion start-col)
      (spiral-write lis loops)
      (picture-mode-exit)
      ;; postprocess
      (spiral-delete-heading-spaces start-col)
      (spiral-replace spiral-replace)
      (goto-char (point-min)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; find loops

;; (spiral-matched-pairs '(a b a e f a) 3) ==> ((0 . 5) (2 . 3))
(defun spiral-matched-pairs (lis min-dist min-start &optional n)
  (setq n (or n 0))
  (if (null (cdr lis)) ;; (cdr nil) is nil.
      nil
    (let ((h (car lis))
          (r (cdr lis)))
      ;; ((position . distance) (position . distance) ...)
      (append
       (mapcar (lambda (c) (cons n c))
               (spiral-matched-pairs-sub lis min-dist min-start n h r))
       (spiral-matched-pairs r min-dist min-start (1+ n))))))

(defun spiral-matched-pairs-sub (lis min-dist min-start n h r)
  (delete nil
          (map-with-index (lambda (x c)
                            (setq c (1+ c)) ;; = distance
                            (and (>= n min-start)
                                 (not (member h (spiral-taboo-chars)))
                                 (eq h x)
                                 (>= c min-dist)
                                 (evenp c)
                                 c))
                          r)))

(defun spiral-taboo-chars ()
  (spiral-string-to-list spiral-taboo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; select best loops

;; (spiral-best-loop (spiral-matched-pairs '(c d d d c b a b a) 2 0) 2)
;; ==> ((0 . 4) (6 . 2))
(defun spiral-best-loop (pairs min-sep)
  (if (null pairs)
      nil
    (let ((s1 (cons (car pairs)
                    (spiral-best-loop (spiral-remove-disqualified (car pairs)
                                                                  (cdr pairs)
                                                                  min-sep)
                                      min-sep)))
          (s2 (spiral-best-loop (cdr pairs) min-sep)))
      (if (>= (spiral-beauty s1) (spiral-beauty s2))
          s1
        s2))))

;; (spiral-beauty '((0 . 5) (2 . 3))) ==> 210
(defun spiral-beauty (pairs)
  (let ((loop-num (length pairs))
        (loop-len (apply #'+ (mapcar (lambda (p) (1+ (cdr p))) pairs))))
    (+ (* loop-num 100) loop-len)))

(defun spiral-remove-disqualified (pair rests min-sep)
  (let ((lim-pos (+ (car pair) (cdr pair) min-sep))
        (lim-dist (cdr pair)))
    (remove-if-not (lambda (p)
                     (and (>= (car p) lim-pos)
                          (<= (cdr p) lim-dist))) ;; loop size must decrease
                   rests)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; write

(defun spiral-write (lis loops &optional c)
  (cond ((null loops) (spiral-write-tail lis (or c 0)))
        ((null c) (spiral-write-head lis loops))
        ((< c (caar loops)) (spiral-write-bridge lis loops c))
        (t (spiral-write-loop lis loops c))))

(defun spiral-write-head (lis loops)
  (picture-movement-right)
  (let ((c (spiral-insert lis 0 (- (caar loops) 6))))
    (spiral-write lis loops c)))

(defun spiral-write-bridge (lis loops c)
  (picture-movement-down)
  (setq c (spiral-insert lis c (+ c 4)))
  (picture-movement-left)
  (setq c (spiral-insert lis c (caar loops)))
  (spiral-write lis loops c))

(defun spiral-write-loop (lis loops c)
  (let ((w (/ (- (cdar loops) 4) 2)))
    (picture-movement-left)
    (setq c (spiral-insert lis c (+ c w)))
    (picture-movement-up)
    (setq c (spiral-insert lis c (+ c 2)))
    (picture-movement-right)
    (setq c (spiral-insert lis c (+ c w)))
    (picture-movement-down)
    (setq c (spiral-insert lis c (+ c 2))))
  (spiral-write lis (cdr loops) c))

(defun spiral-write-tail (lis c)
  (picture-movement-down)
  (setq c (spiral-insert lis c (min (+ c 2) (length lis))))
  (picture-movement-right)
  (spiral-insert lis c (length lis)))

(defun spiral-insert (lis c until)
  (while (< c until)
    (picture-insert (nth c lis) 1)
    (setq c (1+ c)))
  c)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; postprocess

(defun spiral-delete-heading-spaces (max-column)
  (let ((c max-column))
    (goto-char (point-min))
    (while (re-search-forward "^ +" nil t)
      (setq c (min c (current-column))))
    (goto-char (point-min))
    (while (not (eobp))
      (delete-char c)
      (forward-line))))
;;     (while (and (not (eobp))
;;                 (progn
;;                   (delete-char c)
;;                   (= (forward-line) 0)))
;;       nil)))

(defun spiral-replace (alist)
  (mapc (lambda (pair)
          (goto-char (point-min))
          (while (search-forward (car pair) nil t)
            (replace-match (cdr pair) nil t)))
        alist))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; utility

;; (numbering '(a b c)) ==> ((a 0) (b 1) (c 2))
(defun numbering (lis)
  (let ((c 0))
    (mapcar (lambda (x) (prog1
                            (list x c)
                          (setq c (1+ c))))
            lis)))

;; (map-with-index #'cons '(a b c)) ==> ((a . 0) (b . 1) (c . 2))
(defun map-with-index (f lis)
  (mapcar (lambda (xc) (apply f xc)) (numbering lis)))

;; copied from mule-util.el
(defun spiral-string-to-list (string)
  (append string nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; provide

(provide 'spiral)

;;; spiral.el ends here