Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2007-05-19

L-99 (80) (4)

| 00:02 | L-99 (80) (4) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (80) (4) - わだばLisperになる

L-99 P80に挑戦 - L-99:Ninety-Nine Lisp Problems

P80の続き。Scheme版。

もう何が何だか良く分からないけど、これでP80も落着

としよう!

SRFI-42の内包表記とか使ってみようと思ったりもした

んだけども。

解答
;; Scheme
;; -----------------------------------------------------------------------------
;; utility
(define (flatten lst)
  (cond ((null? lst) '() )
	((not (pair? lst)) `(,lst))
	(else `(,@(flatten (car lst))
		,@(flatten (cdr lst))))))

(define (sort-by-symbol-name lst pos-fn)
  (sort lst
	(lambda (a b)
	  (string<? (symbol->string (pos-fn a)) (symbol->string (pos-fn b))))))

;; -----------------------------------------------------------------------------
;; Graph Term
;; 1)
(define (graph-term->edge-clause expr)
  (cadr expr))

;; 2) DIRECTED
(define graph-term->arc-clause/directed graph-term->edge-clause)

;; 3) LABELLED
(define graph-term->arc-clause/labelled graph-term->edge-clause)

;; 1)
(define (edge-clause->graph-term expr)
  `(,(sort-by-symbol-name
      (delete-duplicates
       (fold append '() expr))
      identity)
    ,expr))

;; 2) DIRECTED
(define arc-clause->graph-term/directed arc-clause->graph-term/labelled)

;; 3) LABELLED
(define (arc-clause->graph-term/labelled expr)
  `(,(sort-by-symbol-name
      (delete-duplicates
       (fold (lambda (item retlst) `(,@(drop-right item 1) ,@retlst))
	     '() expr))
      identity)
    ,expr))

;; -----------------------------------------------------------------------------
;; Adjacency List
;; 1)
(define (graph-term->adjacency-list expr)
  `(,@(map (lambda (item)
	     `(,item 
	       ,(remove null?
			(delete-duplicates 
			 (flatten 
			  (map (lambda (lst)
				 (remove (cut eq? item <>)
					 (if (memq item lst)
					     lst
					     '() )))
			       (cadr expr)))))))
	   (car expr))))

;; 2) DIRECTED
(define (graph-term->adjacency-list/directed expr)
  (map (lambda (item) `(,item ,(get-direction item (cadr expr))))
       (car expr)))

(define (get-direction from dist-lst)
  (fold (lambda (item retlst)
	  (if (eq? from (car item))
	      `(,@retlst ,(cadr item))
	      retlst))
	'() dist-lst))

;; 3) LABELLED
(define (graph-term->adjacency-list/labelled expr)
  (map (lambda (item)
	 `(,item ,(get-direction/labelled item (cadr expr))))
       (car expr)))
                      
(define (get-direction/labelled from dist-lst)
  (fold (lambda (item retlst)
	  (if (eq? from (car item))
	      `(,@retlst (,(cadr item) ,(caddr item)))
	      retlst))
	'() dist-lst))

;; 1)
(define (adjacency-list->graph-term expr)
  `(,(map car expr)
    ,(sort-by-symbol-name
      (delete-duplicates
       (fold (lambda (item retlst)
	       `(,@retlst 
		 ,@(map (lambda (j)
			  (sort-by-symbol-name `(,(car item) ,j) identity))
			(cadr item))))
	     '() expr))
      car)))

;; 2) DIRECTED
(define adjacency-list->graph-term/directed adjacency-list->graph-term)

;; 3) LEBELLED
(define (adjacency-list->graph-term/labelled expr)
  `(,(map car expr)
    ,(fold (lambda (item retlst)
                 `(,@retlst ,@(fold (lambda (num ret)
                                          (if (not (null? num))
                                              `(,@ret (,(car item) ,@num))
					      ret))
                                      '() (cadr item))))
             '() expr)))

;; -----------------------------------------------------------------------------
;; Human Friendly

;; 1)
(define (graph-term->human-friendly expr)
  (graph-term->human-friendly-aux expr "-"))

(define (graph-term->human-friendly-aux expr separater)
  (sort `(,@(map (lambda (item)
		   (string-append (symbol->string (car item)) 
				  separater 
				  (symbol->string (cadr item))))
		 (cadr expr))
	  ,@(map symbol->string
		 (lset-difference eq? (car expr) (flatten (cadr expr)))))
	string<?))

;; 2) DIRECTED
(define (graph-term->human-friendly/directed expr)
  (graph-term->human-friendly-aux expr ">"))

;; 3) LABELLED
(define (graph-term->human-friendly/labelled expr)
  (sort `(,@(map (lambda (item)
		   (match-let (((a b c) item))
			      (format #f "~A>~A/~A" a b c)))
		 (cadr expr))
	  ,@(map symbol->string
		 (lset-difference eq? (car expr) (flatten (cadr expr)))))
	string<?))

;; 1)
(define (human-friendly->graph-term expr)
  (human-friendly->graph-term-aux expr string-split/-))

(define (human-friendly->graph-term-aux expr split-fn)
  (let ((item-list 
	 (map (lambda (item)
		(if (null? (cdr item))
		    (string->symbol (car item))
		    `(,(string->symbol (car item)) 
		      ,(string->symbol (cadr item)))))
	      (split-fn expr))))
    `(,(delete-duplicates (flatten item-list)) 
      ,(remove (lambda (i) (not (pair? i))) item-list))))

(define (string-split/- strlst)
  (map (lambda (item) (string-split item #\-))
       strlst))

;; 2) DIRECTED
(define (human-friendly->graph-term/directed expr)
  (human-friendly->graph-term-aux expr string-split/>))

(define (string-split/> strlst)
  (map (lambda (item) (string-split item #\>))
       strlst))

;; 3) LABELLED
(define (human-friendly->graph-term/labelled expr)
  (let ((item-list 
	 (map (lambda (item)
		(if (null? (cdr item))
		    (string->symbol (car item))
		    (match-let (((from to label) item))
			       `(,(string->symbol from)
				 ,(string->symbol to)
				 ,(string->number label)))))
	      (string-split/labelled expr))))
    `(,(delete-duplicates
	(fold (lambda (item retlst)
		(if (pair? item) 
		    `(,@retlst ,@(drop-right item 1) )
		    `(,@retlst ,item)))
	      '() item-list))
      ,(remove (lambda (item) (not (pair? item))) item-list))))

(define (string-split/labelled strlst)
  (map (lambda (str)
	 (if (string-scan str #\/)
	     (match-let (((from to-label) (string-split str #\>)))
			(match-let (((to label) (string-split to-label #\/)))
				   `(,from ,to ,label)))
	     `(,str)))
       strlst))
;

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20070519