;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               fmt-index.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;    
;;;;    Format self-incrementing indices.
;;;;    
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2015-04-09 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    AGPL3
;;;;    
;;;;    Copyright Pascal J. Bourguignon 2015 - 2015
;;;;    
;;;;    This program is free software: you can redistribute it and/or modify
;;;;    it under the terms of the GNU Affero General Public License as published by
;;;;    the Free Software Foundation, either version 3 of the License, 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 Affero General Public License for more details.
;;;;    
;;;;    You should have received a copy of the GNU Affero General Public License
;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;**************************************************************************

(defun cardinal-to-base (n base)
  (check-type n    (integer 0))
  (check-type base (integer 2))
  (if (zerop n)
      (list 0)
      (loop
        :while (plusp n)
        :collect (mod n base)
        :do (setf n (truncate n base)))))

(defun encode-index (index from to)
  (let* ((letters        (coerce (loop :for code :from (char-code from) :to (char-code to)
                                       :collect (code-char code)) 'vector))
         (base           (length letters))
         (digits         (cardinal-to-base (1- index) base))
         (representation (make-string (length digits))))
    (loop
      :for i :from (1- (length representation)) :downto 0
      :for digit :in digits
      :do (setf (aref representation i) (aref letters digit)))
    representation))


(let ((indices (list 0)))
  (defun cl-user::fmt-index (stream arg colon at &rest parameters)
    "
ARG is ignored: pass NIL or use ~:* before or after to eat previous or
next argument and regurgitate.

Set current index to 42:     ~,42@/fmt-index/
Pop indices:                 ~0@/fmt-index/
push 42 onto indices:        ~1,42@/fmt-index/
clear indices stack:         ~2@/fmt-index/

format index (and increment):

   ~V,V,V,V,V/fmt-index/  width delim mode from-ch to-ch

    mode
    nil   normal integer formating ~D
    0:    ~R   (four)
    1:    ~:R  (fourth)
    2:    ~@R  (IV)
    3:    ~:@R (IIII)
    4:    use letters between the two given in the following parameters inclusive,
          or by default, lowercase letters a b … z aa ab … zz …
"
    (declare (ignore arg))
    (if at
        (destructuring-bind (&optional op (start 0) &rest ignored) parameters
          (declare (ignore ignored))
          (check-type op    (or null (integer 0 2)))
          (check-type start integer)
          (case op
            ((nil) (setf (first indices) start))
            ((0)   (pop indices))
            ((1)   (push start indices))
            ((2)   (setf indices (list start)))))
        (destructuring-bind (&optional width delim mode (from #\a) (to #\z) &rest ignored)
            parameters
          (declare (ignore ignored))
          (check-type width (or null integer))
          (check-type delim (or null character))
          (check-type mode  (or null (integer 0 4)))
          (format stream "~V<~A~>" (or width 0)
                  (format nil (case mode
                                ((nil)    "~D")
                                ((0)      "~R")
                                ((1)      "~:R")
                                ((2)      "~@R")
                                ((3)      "~@:R")
                                ((4)      "~A"))
                          (if (eql mode 4)
                              (encode-index (first indices) from to)
                              (first indices))))
          (format stream "~@[~A~]" delim)
          (incf (first indices))))))


#||

(let ((items  '(apple banana figue kiwi orange)))
  (format t "~%~2,1@/fmt-index/~:*~{~&~,')/fmt-index/~:* ~(~A~)~^,~}.~%" items))


1) apple,
2) banana,
3) figue,
4) kiwi,
5) orange.

(let ((items  '(apple banana figue kiwi orange)))
  (format t "~%~2,1@/fmt-index/~:*~{~&~,'),4,'α,'ω/fmt-index/~:* ~(~A~)~^,~}.~%" items))

α) apple,
β) banana,
γ) figue,
δ) kiwi,
ε) orange.


(let ((items  '((apple (red yellow green white))
                (banana (yellow)) (figue (violet green))
                (kiwi (green)) (orange (orange blue)))))
  (format t "~%~2,1@/fmt-index/~:*~{~&~,')/fmt-index/~:* ~{~(~A~):~
              ~1,1@/fmt-index/~:*~
                ~{~&~6,'.,2/fmt-index/~:* ~(~A~)~^,~}~
              ~:*~0@/fmt-index/~
             ~}~^,~}.~%" items))


1) apple:
     I. red,
    II. yellow,
   III. green,
    IV. white,
2) banana:
     I. yellow,
3) figue:
     I. violet,
    II. green,
4) kiwi:
     I. green,
5) orange:
     I. orange,
    II. blue.

||#