string-succ(次の文字列)が意外と難しい。

scheme

逆引きrubyの "次"の文字列を取得するを取得するというサンプルのString#succと同じ結果を返す手続きが意外と難しい。書いているうちにぐちゃぐちゃになってしまった。たぶん、もっと綺麗に書ける気がする。

だいたいの仕様

文字列を受け取って、

  • 数字の場合はインクリメント
  • 数字以外の文字からなる文字列の場合は末尾の文字をインクリメント
  • {数字以外}+{数字}+となっている文字列は
    • 数字の文字列としての長さの範囲内ではインクリメント
    • 範囲を越えた場合は、数字以外の部分の末尾の文字をインクリメント(数字は0に)
    • それぞれの数字は、正しい桁数だけ"0"で埋めなければならない。

実行例

(string-succ "9") ; => "10"
(string-succ "a") ; => "b"
(string-succ "AAA") ; => "AAB"
(string-succ "B00") ; => "B01"
(string-succ "B09") ; => "B10"
(string-succ "B19") ; => "B20"
(string-succ "B019") ; => "B020"
(string-succ "A99") ; => "B00"
(string-succ "A099") ; => "A100"
(string-succ "A0099") ; => "A0100"
(string-succ "A0399") ; => "A0400"

code

(define (string-succ s)
  (define (dispatch-type cs) ;;return values are reversed
    (let loop ((nums '()) (prefix '()) (seq cs) (num? #f))
      (match seq
	[() (values prefix nums)]
	[(c . seq*) 
	 (cond ((and num? (not (char-numeric? c)))
		(values '() (reverse cs)))
	       ((char-numeric? c)
		(loop (cons c nums) prefix seq* #t))
	       (else
		(loop nums (cons c prefix) seq* #f)))])))
  (define (chars-succ cs) ;;cs is reversed-seq
    (let1 last-c (integer->char (+ 1 (char->integer (car cs))))
      (apply string (reverse (cons last-c (cdr cs))))))
  (define (prefixed-nums-succ prefix nums) ;;both are reversed-seq
    (define (zero-count-from-left cs)
      (match cs
	[(_) 0]
	[(#\0 . cs*) (+ 1 (zero-count-from-left cs*))]
	[(_ . cs*) 0]))
    (let* ((rnums (reverse nums))
	   (zcount (zero-count-from-left rnums))
   	   (n+ (+ 1 (string->number (apply string rnums))))
	   (snums+ (number->string n+))
	   (nums-len (length nums)))
      (cond ((or (> zcount 0) (= nums-len (+ zcount (string-length snums+))))
	     (let1 zcount* (if (and (zero? (modulo n+ 10))
				    (char-ci=? #\1 (string-ref snums+ 0)))
			       (- zcount 1) 
			       zcount)
	       (string-append (apply string (reverse prefix))
			      (make-string zcount* #\0)
			      snums+)))
	    (else
	     (string-append (chars-succ prefix)
			    (make-string nums-len #\0))))))
  (or (and-let* ((n (string->number s)))
	(number->string (+ n 1)))
      (receive (xs nums) (dispatch-type (string->list s))
	(cond ((null? nums) (chars-succ xs))
	      (else (prefixed-nums-succ xs nums))))))