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-29

L-99 (27)

| 15:04 | L-99 (27) - わだばLisperになる を含むブックマーク はてなブックマーク - L-99 (27) - わだばLisperになる

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

久々の更新。先に進めないので、後回しにしていたP27に挑戦。

残りの問題:'(55 58-60 63 66 80-94 96-99)

P27

解答
;; Lisp Machine Lisp
;; -----------------------------------------------------------------------------
(defun group (lst pat)
  (group-rpat lst (reverse pat)))

(defun group-rpat (lst pat)
  (if (> (apply #'+ pat) (length lst))
      (error "foo!")
    (cond ((null pat) () )
	  ((= (length lst) (car pat)) `(,lst))
	  ((= 1 (length pat)) 
	   (sep2 lst (car pat)))
	  ('t (sep2s (group-rpat lst (cdr pat)) (car pat))))))

(defun sep2 (lst num)
  (let ((front (combination num lst)))
    (mapcar #'(lambda (item) 
		`(,item ,(setdiff lst item)))
	    front)))

(defun sep2s (lsts num)
  (do ((l lsts (cdr l))
       (retlst () ))
      ((null l) retlst)
    (setq retlst 
	  `(,@retlst 
	    ,@(mapcar #'(lambda (item)
			     (if (cadr item)
				 `(,@(butlast (car l)) ,(car item) ,(cadr item)) 
				 `(,@(butlast (car l)) ,(car item))))
		   (sep2 (car (last (car l))) num))))))

;; Utils (from Maclisp LSETS.LSP)
(defun y-x+z (y x z &aux y-x)
  (mapc #'(lambda (xx) (or (memq xx x) (push xx y-x))) y)
  (nreconc y-x z))

(defun setdiff (x y)
  (if (dolist (xx y)
	(let ((res (memq xx x)))
	  (and res (return xx))))
      (y-x+z x y () )
    x))

;; Common Lisp
;; -----------------------------------------------------------------------------
(defun group (lst pat)
  (group-rpat lst (reverse pat)))

(defun group-rpat (lst pat)
  (if (> (apply #'+ pat) (length lst))
      (error "foo!")
      (cond ((endp pat) '()	)
	    ((= (length lst) (car pat)) `(,lst))
	    ((= 1 (length pat)) 
	     (sep2 lst (car pat)))
	    ('t (sep2s (group-rpat lst (cdr pat)) (car pat))))))

(defun sep2 (lst num)
  (let ((front (combination num lst)))
    (map 'list #'(lambda (item) 
		   `(,item ,(set-difference lst item)))
	 front)))

(defun sep2s (lsts num)
  (do ((l lsts (cdr l))
       (retlst '()))
      ((endp l) retlst)
    (setq retlst 
	  `(,@retlst 
	    ,@(map 'list #'(lambda (item)
			     (if (cadr item)
				 `(,@(butlast (car l)) ,(car item) ,(cadr item)) 
				 `(,@(butlast (car l)) ,(car item))))
		   (sep2 (car (last (car l))) num))))))

;; Scheme
;; -----------------------------------------------------------------------------
(define (group lst pat)
  (group-rpat lst (reverse pat)))

(define (group-rpat lst pat)
  (if (> (apply + pat) (length lst))
      '()
      (cond ((null? pat) 
	     '() )
	    ((= (length lst) (car pat))
	     `(,lst))
	    ((= 1 (length pat)) 
	     (sep2 lst (car pat)))
	    (else 
	     (sep2s (group-rpat lst (cdr pat)) (car pat))))))

(define (sep2 lst num)
  (if (> num (length lst))
      '()
      (let ((front (combination num lst)))
	(map  (lambda (item) 
		`(,item ,(lset-difference eq? lst item)))
	      front))))

(define (sep2s lsts num)
  (let frob ((l lsts)
	     (retlst '() ))
    (if (null? l)
	retlst
	(frob (cdr l)
	      `(,@retlst 
		,@(map (lambda (item)
			 `(,@(drop-right (car l) 1) ,@(remove null? item)))
		       (sep2 (last (car l)) num)))))))

ゲスト



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