ディレクトリのグループ化

Scheme 30分プログラム

30分プログラム、その170。ディレクトリのグループ化。

例えば、"foo1"、"foo2"、"foo3"という3つのファイルがあったら、これをfooというディレクトリを作ってそこに入れるやつ。

使い方

$ ls
bar-2.0    foo-1.0.0  foo-1.0.1  foo-1.2

$ dir_group *

# foo-/以下にfoo-1.0.0、foo-1.0.1、foo-1.2がコピーされる
$ ls
bar-2.0  foo-/

$ ls foo-
foo-1.0.0  foo-1.0.1  foo-1.2

ソースコード

#! /opt/local/bin/gosh
;; -*- mode:scheme; coding:utf-8 -*-
;;
;; dir_group.scm - directory grouping
;;
;; Copyright(C) 2007 by mzp
;; Author: MIZUNO Hiroki <hiroki1124@gmail.com> 
;; http://mzp.sakura.ne.jp/
;;
;; Timestamp: 2007/10/31 22:36:34
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the same terms as Scheme itself.
;;
(use srfi-1)
(use file.util)

;; 数値以外の部分を取り出す
;;   (extract-num "web2.0") -> "web"
(define (extract-num str)
  (rxmatch-if (rxmatch #/(^.*?)[.0-9]+$/ str)
      (_ etc)
    etc
    str))

;; リストのグループ分け。sort済みであることが条件
;; fnで等しいものが結合される
;;
;; (group '(1 1 2 3) eq?) => '((1 1) (2) (3))
(define (group lst fn)
  (if (or (eq? lst '()) (eq? (cdr lst) '()))
      (list lst)
      (receive 
	  (same other) 
	  (span (lambda(y) (fn (car lst) y)) (cdr lst))
	(cons (cons (car lst) same)
	      (group other fn)))))

;; ファイルを実際に移動したりする
;; 入力例: (("foo-" . "foo-1.0.0") ("foo-" . "foo-1.1.0") ("foo-" . "foo-1.5.0"))
(define (proc-file xs)
  ;; ファイルが0か1のときは何もしない
  (if (not (or (eq? xs '()) (eq? (cdr xs) '())))
      (begin
	(make-directory* (caar xs)) ; ディレクトリの生成
	(for-each (lambda (x) 
		    (let ((old (cadr x))
			  (new (string-append 
				(car x) 
				"/" 
				(sys-basename (cadr x)))))
		      (move-file old new)))
		  xs))))

(define (dir-group file-list)
  (for-each proc-file
	    (group
	     (sort 
	      (zip (map extract-num file-list)
		   file-list)
	      (lambda(x y) (string<? (car x) (car y))))
	     (lambda(x y) (string=? (car x) (car y))))))

(define file-list '("foo-1.0.0"  "bar-2.0" "foo-1.1.0" "foo-1.5.0"))

(define (main args)
  (dir-group (cdr args)))

参考