更新日時ごとのグループ分け(その2)

Scheme 30分プログラム

2日ぶりの30分プログラム、その189。id:mzp:20071121の改良版。
shiroさんにgauche.collectionを教えてもらったので、それを使ってみる。

使い方

$ gosh mtime.scm *
2007/07/19: 124
2007/07/20: 1
2007/07/23: 1
2007/07/26: 1
2007/07/27: 1
2007/07/29: 1
2007/07/31: 3
2007/08/01: 2
2007/08/02: 1
2007/08/03: 1

今度は正しく動いた。

30分プログラムのディレクトリなので、毎日一つづつファイルが作成されている。
7/19が多いのは、多分この日にSubversionで管理しはじめたからだろうな。

ソースコード

#! /opt/local/bin/gosh
;; -*- mode:scheme; coding:utf-8 -*-
;;
;; mtime2.scm -
;;
;; Copyright(C) 2007 by mzp
;; Author: MIZUNO Hiroki
;; http://mzp.sakura.ne.jp/
;;
;; Timestamp: 2007/11/24 15:38:16
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the same terms as Scheme itself.
;;
(use srfi-1)
(use srfi-19)
(use file.util)
(use gauche.collection)

;; get file modifier time by #<sys-tm>
(define mtime (compose sys-localtime file-mtime))

;; convert sys-tm to list(year month day)
(define (time->date time)
  (list (+ (slot-ref time 'year) 1900)
	(+ (slot-ref time 'mon) 1)
	(slot-ref time 'mday)))

;; (((2007 10 24) . "/") ((2007 10 24) . "/tmp")) => ((2007 10 24) "/" "/tmp")
(define (concat-group coll)
  (let1 key (caar coll)
    (cons key (map cdr coll))))

(define (group-by-mtime file-list)
  (map concat-group
       (group-collection
	(map cons (map (compose time->date mtime)
		       file-list)
	     file-list)
	:key car :test equal?)))

(define (print-assoc lst)
  (define (f group)
    (let ((key  (car group))
	  (body (cdr group)))
      (apply format #t "~4'0d/~2'0d/~2'0d: " key)
      (format #t "~d~%" (length body))))
  (for-each f lst))

(define (list-compare lhs rhs)
  (cond
   ((and (eq? lhs '()) (eq? rhs '())) 0)
   ((eq? lhs '()) -1)
   ((eq? rhs '()) 1)
   (else 
    (let1 c (compare (car lhs) (car rhs))
      (if (eqv? c 0)
	  (list-compare (cdr lhs) (cdr rhs))
	  c)))))

(define (main argv)
  (print-assoc (sort (group-by-mtime (cdr argv))
		     (lambda (a b)
		       (< (list-compare (car a) (car b)) 0)))))

参考