Chat (Lingr.com)
Informaiton
Daily
Column
- MySQL日本語の旅(5/1)
- アクセス向上秘伝(5/9)
- 一風変ったHaskellλ門(6/13)
- SICP Answer Book (5/31) 問題3.26追加
Zope Solution
Extra
アーカイブ
OSS案内所
Site Info
関連リンク
- 2004: 01 02 03 04 05 06 07 08 09 10 11 12
- 2005: 01 02 03 04 05 06 07 08 09 10 11 12
- 2006: 01 02 03 04 05 06 07 08 09 10 11 12
先月の一行
- 2006-04-28 [Haskell] 文字列中の文字の変換
- 2006-04-27 [Haskell] drawTree の実装
- 2006-04-26 [Gauche] 部分木のあげさげ
- 2006-04-25 [Haskell] 多分木の印字
- 2006-04-24 [quiz] 部分木の交換
- 2006-04-21 [Haskell] 部分木の格下げ
- 2006-04-20 [quiz] 部分木の格上げ
- 2006-04-19 [Postfix] Postfixでデーモンを動かさずsendmail互換コマンドで送信だけしたい
- 2006-04-18 [Haskell] f (f x) ==> -x
- 2006-04-17 [quiz] f (f x) ==> -x
- 2006-04-14 [Haskell] リストの尻尾を交換する(ワケワカ編)
- 2006-04-13 [Haskell] リストの尻尾を交換する(続)
- 2006-04-12 [Haskell] リストの尻尾を交換する．
- 2006-04-11 [Haskell] リストの要素の交換
- 2006-04-10 [tarai] たらいまわし再び
- 2006-04-07 [Gauche] Rose tree のサブツリーの置き換え
- 2006-04-06 [JavaScript] script.aculo.usを使った項目入れ替え時のイベント通知(改定版)
- 2006-04-05 [Gauche] Rose treeの子要素の順番を入れ替える
- 2006-04-04 [MacOS] MacOS 10.4でqpopperを動かす
- 2006-04-03 [MacOS] MacOS 10.4でPostfixを動かす
2006-04-28 [Haskell] 文字列中の文字の変換
大抵のUNIX-likeシステムにある tr のごく簡易版． Haskell はスケるよに 刺激をうけてより関数プログラミングぽく書いてみた．
tr :: [Char] -> [Char] -> (String -> String)
tr set1 set2 = map trans
where
trans = foldr (uncurry add) id (zip set1 set2)
add k v s q | k == q = v
| otherwise = s q
文字を変換する関数 trans を foldr で作っているところが面白いでしょ． でしょ．でしょ．(^o^)
実行例
*Main> tr "a" "A" "abracadabra" "AbrAcAdAbrA" *Main> tr "aaa" "xyz" "abracadabra" "xbrxcxdxbrx"
あれっ．これだめだ．tr "aaa" "xyz" "abracadabra" は tr "a" "z" "abracadabra" と同じじゃなきゃいけないのに．．．foldr じゃなくて foldl だ！
tr :: [Char] -> [Char] -> (String -> String)
tr set1 set2 = map trans
where
trans = foldl (flip $ uncurry add) id (zip set1 set2)
add k v s q | k == q = v
| otherwise = s q
実行例
*Main> tr "a" "A" "abracadabra" "AbrAcAdAbrA" *Main> tr "aaa" "xyz" "abracadabra" "zbrzczdzbrz"
ぱちぱち
--nobsun
2006-04-27 [Haskell] drawTree の実装
ライブラリのソースコードを読むと 2006-04-25で使った drawTree の実装はシンプルです．
drawTree :: Tree String -> String
drawTree = unlines . draw
draw :: Tree String -> [String]
draw (Node x ts0) = x : drawSubTrees ts0
where drawSubTrees [] = []
drawSubTrees [t] =
"|" : shift "`- " " " (draw t)
drawSubTrees (t:ts) =
"|" : shift "+- " "| " (draw t) ++ drawSubTrees ts
shift first other = zipWith (++) (first : repeat other)
うまいですねぇ．．．つくづく．．．
--nobsun
There is no comment.
2006-04-26 [Gauche] 部分木のあげさげ
Haskellで書いたものをGaucheで書きなおした．Gaucheには util.matchモジュールがあるため，Haskellのコードをほぼそのまま書き 移すだけ(でよかったはずだった．．．^^;)
(use util.match)
;; Constructor
(define (rose-tree content children)
`(Rose ,content ,children))
;; Predicate and selectors
;;;; N.B.
;;;; rose-tree-content cannot apply to a tree which may have a #f as content!
(define rose-tree? (match-lambda (`(Rose ,_ ,_) #t) (else #f)))
(define rose-tree-content (match-lambda (`(Rose ,c ,_) c) (else #f)))
(define rose-tree-children (match-lambda (`(Rose ,_ ,cs) cs) (else #f)))
;; Break rose-tree by a predicate
(define (break-rose-tree pred tree)
(match tree
(`(Rose ,c ,cs)
(if (pred c)
(cons (cons '() (list tree)) '())
(match (break-rose-forest pred cs)
('() (list (cons (list tree) '())))
(xs (cons (cons '() (list tree)) xs)))))))
(define (break-rose-forest pred forest)
(match forest
('() '())
(xxs (match xxs
(`(,x . ,xs)
(match (break-rose-tree pred x)
(`((,_ . ()) . ,_)
(match (break-rose-forest pred xs)
('() '())
(`((,ys . ,zs) . ,ws) `((,(cons x ys) . ,zs) . ,ws))))
(`(,_ . ,ys) `((() . ,xxs) . ,ys))))))))
(define (up-rose-tree pred tree)
(define (up ffs)
(match ffs
('() #f)
(`(,_ . ()) #f)
(`((,xs . (,y . ,ys)) (,zs . (,w . ,ws)))
(let1 y1 (rose-tree (rose-tree-content y) (append zs ws))
`(,xs . (,y1 . (,w . ,ys)))))
(`((,xs . (,y . ,ys)) . ,rs)
(match (up rs)
(`(,zs . ,ws)
(let1 y1 (rose-tree (rose-tree-content y) (append zs ws))
`(,xs . (,y1 . ,ys))))))))
(match tree
(`(Rose ,c ,cs)
(match (up (break-rose-forest pred cs))
(#f (values #f tree))
(`(,ys . ,zs) (values #t (rose-tree c (append ys zs))))))))
(define (down-rose-tree pred tree) ;; 注意：このコードにはバグがあります．
(define (down ffs)
(match ffs
('() #f)
(`((() . ,_)) #f)
(`((,xs . (,y . ,ys)))
(match (reverse xs)
(`((Rose ,z ,zs) . ,ws)
`(,(reverse `((Rose ,z ,(append zs (list y))) . ,ws)) . ,ys))))
(`((,xs . ((Rose ,y ,_) . ys)) . ,zs)
(match (down zs)
(#f #f)
(`(,us . ,vs) `(,xs . ((Rose ,y ,(append us vs)) . ,ys)))))))
(match tree
(`(Rose ,c ,cs)
(match (down (break-rose-forest pred cs))
(#f (values #f tree))
(`(,ys . ,zs) (values #t (rose-tree c (append ys zs))))))))
ところが，このコードにはすごく分りにくい(少くとも私には)バグがあった． その所為で同僚がハマッたらしい．スマソ m(_._)m
例題ではちゃんと動くのだが，末端のノードを sage ようとしたら パターンエラー，マッチすべきパターンがない．．．
バグは down-rose-tree の内部で定義した down の中にあった． 引数 ffs のパターンマッチをやっているところで， 最後のパターン
`((,xs . ((Rose ,y ,_) . ys)) . ,zs)
が間違い．正しくは，
`((,xs . ((Rose ,y ,_) . ,ys)) . ,zs)
が〜ん．
--nobsun
There is no comment.
2006-04-25 [Haskell] 多分木の印字
多分木に関する関数を書いていると，結果を簡単に確かめるために多分木を 見やすく印字する方法が欲しくなる． Glasgow Haskell CompilerのData.Treeモジュールには，文字列ラベルの付いた 多分木をディレクトリツリー形式の文字列に変換する drawTree がある． これを使うとノードのラベルが Show クラスのインスタンスである 多分木を簡単に印字できる showTree が簡単に定義できる．
showTree :: Show a => Tree a -> String
showTree = drawTree . fmap show
testTree :: Tree Char
testTree = Node 'A' [ Node 'B' [ Node 'F' []
, Node 'G' [ Node 'L' []
, Node 'M' []
]
]
, Node 'C' [ Node 'H' []
, Node 'I' [ Node 'N' []
, Node 'O' [ Node 'P' []
, Node 'Q' []
]
]
, Node 'J' []
]
, Node 'D' []
, Node 'E' [ Node 'K' []
]
]
testTree は 2006-04-20で例にあげた木(左側)のデータである． これを showTree を使って印字すると
*Main> putStr $ showTree testTree 'A' | +- 'B' | | | +- 'F' | | | `- 'G' | | | +- 'L' | | | `- 'M' | +- 'C' | | | +- 'H' | | | +- 'I' | | | | | +- 'N' | | | | | `- 'O' | | | | | +- 'P' | | | | | `- 'Q' | | | `- 'J' | +- 'D' | `- 'E' | `- 'K'
また，部分木の格上げ upTree をラベルが 'I' の部分木に施したあとの木を 印字すると
'A' | +- 'B' | | | +- 'F' | | | `- 'G' | | | +- 'L' | | | `- 'M' | +- 'C' | | | +- 'H' | | | `- 'J' | +- 'I' | | | +- 'N' | | | `- 'O' | | | +- 'P' | | | `- 'Q' | +- 'D' | `- 'E' | `- 'K'
--nobsun
There is no comment.
2006-04-24 [quiz] 部分木の交換
またまた，木に関するクイズ．
述語を2つ(pとq)と，木を与えて，pを満すラベルの付いた部分木とqを満す部分木を 交換する．
ただし，
- どちらかの述語を満す部分木がない
- 一方の部分木が他方の部分木の子孫である
場合は何もせず元の木を返す．
--nobsun
There is no comment.
2006-04-21 [Haskell] 部分木の格下げ
2006-04-20の逆?
述語と木を与えて，述語を満すラベルの付いた部分木をその兄の末っ子に する関数を書け．たとえば，ラベルが D かどうかを判定する述語と左の木を 与えると，右の木が返る．
ただし，
- 述語を満す部分木が無い
- 述語を満す部分木に兄がいない
場合は何もせず元の木を返す．
儂のプログラムは以下のようなもの， 昨日のquizの解として書いた upTree と合せて ツッコんで下さいませ．
import Data.Tree
type Pred a = a -> Bool
breakTree :: Pred a -> Tree a -> [(Forest a, Forest a)]
breakTree p t@(Node x xs)
| p x = [([],[t])]
| otherwise = case breakForest p xs of
[] -> [([t],[])]
ys -> ([],[t]) : ys
breakForest :: Pred a -> Forest a -> [(Forest a, Forest a)]
breakForest _ [] = []
breakForest p xxs@(x:xs)
= case breakTree p x of
(_,[]):_ -> case breakForest p xs of
[] -> []
(ys,zs):ws -> (x:ys,zs):ws
_:ys -> ([],xxs):ys
upTree :: Pred a -> Tree a -> Tree a
upTree p t@(Node x xs) = case up $ breakForest p xs of
Nothing -> t
Just (ys,zs) -> Node x (ys++zs)
up :: [(Forest a, Forest a)] -> Maybe (Forest a, Forest a)
up [] = Nothing
up [_] = Nothing
up [(xs,y:ys),(zs,w:ws)] = Just (xs,y':w:ys)
where y' = case y of Node v _ -> Node v (zs++ws)
up ((xs,y:ys):rs) = case up rs of
Just (zs,ws) -> Just (xs,y':ys)
where y' = case y of Node v _ -> Node v (zs++ws)
downTree :: Pred a -> Tree a -> Tree a
downTree p t@(Node x xs) = case down $ breakForest p xs of
Nothing -> t
Just (ys,zs) -> Node x (ys++zs)
down :: [(Forest a, Forest a)] -> Maybe (Forest a, Forest a)
down [] = Nothing
down [([],_)] = Nothing
down [(xs,y:ys)] = case reverse xs of
Node z zs : ws
-> Just (reverse (Node z (zs++[y]):ws),ys)
down ((xs,Node y _:ys):zs) = case down zs of
Nothing -> Nothing
Just (us, vs) -> Just (xs, Node y (us++vs):ys)
--nobsun
hanatani: (Sat Apr 22 14:26:39 2006
)
downTree :: (a -> Bool) -> Tree a -> Tree a
downTree p t = head $ downTree' t ++ [t]
where
downTree' t@(Node _ []) = [t]
downTree' (Node x ts)
= case break (p . rootLabel) ts of
(lts@(_:_), t:rts) ->
case (init lts, last lts) of
(lts', lt@(Node y ts')) ->
[Node x (lts' ++ [Node y (ts' ++ [t])] ++ rts)]
_ -> do (ts', t:ts) <- splits ts
t' <- downTree' t
return (Node x (ts' ++ [t'] ++ ts))
upTree :: (a -> Bool) -> Tree a -> Tree a
upTree p t = head $ upTree' t ++ [t]
where
upTree' t@(Node x []) = [t]
upTree' (Node x ts)
= do (lts, t@(Node y cts):rts) <- splits ts
(lts', t':rts') <- splits cts
guard (p $ rootLabel t')
return (Node x (lts ++ [Node y (lts' ++ rts'), t'] ++ rts))
++ do (lts, t:rts) <- splits ts
t' <- upTree' t
return (Node x (lts ++ [t'] ++ rts))
splits :: [a] -> [([a], [a])]
splits [] = [([], [])]
splits xxs@(x:xs) = ([], xxs):[(x:ys, zs) | (ys, zs) <- splits xs]
2006-04-20 [quiz] 部分木の格上げ
各ノードにラベルの付いている多分木を考える．
述語と木を与えて，述語を満すラベルの付いた部分木をその親の直ぐの弟に する関数を書け．たとえば，ラベルが I かどうかを判定する述語と左の木を 与えると，右の木が返る．
ただし，
- 述語を満す部分木が無い
- 述語を満す部分木の親がトップレベル
の場合には，何もせず元の木を返す．
(問題文の表現を変更(2006-04-21))
副作用なしで書くのはちょっとだけ面倒かも． (副作用バリバリなら簡単かどうかはピュアな儂には分らない :p)
--nobsun
向井: (Thu Apr 20 12:53:51 2006
)
data Tree a = Leaf a
| Node a [Tree a]
deriving Show
content (Leaf a) = a
content (Node a _) = a
rankUp' :: (a -> Bool) -> Tree a -> [Tree a]
rankUp' _ l@(Leaf a) = [l]
rankUp' f (Node a children) =
if null xs
then [Node a (concatMap (rankUp' f) children)]
else Node a (concatMap (rankUp' f) ys) : xs
where (xs, ys) = partition (f.content) children
rankUp :: (a -> Bool) -> Tree a -> Tree a
rankUp f t = head $ rankUp' f t
ルート直下のノードで条件が成立したときの挙動がよくわかりませんが……。
nobsun: (Thu Apr 20 15:24:19 2006
)
ルート直下は「親がトップレベルの場合には，何もせず元の木を返す．」ということで。。。ううむ、表現がわるいか。
nobsun: (Thu Apr 20 16:19:09 2006
)
Data.Treeを使えば多分木を自前で定義しなくてもいいので，もうすこし短くなるかな． import Data.List import Data.Tree rankUp :: (a -> Bool) -> Tree a -> Tree a rankUp = (head .) . rankUp' rankUp' :: (a -> Bool) -> Tree a -> Forest a rankUp' p t@(Node _ []) = [t] rankUp' p t@(Node x ts) = case partition (p . rootLabel) ts of (xs,ys) -> Node x (concatMap (rankUp' p) ys) : xs
nobsun: (Thu Apr 20 16:24:19 2006
)
副作用なしでも全然めんどうじゃないじゃん。 さては、用意してたのは面倒な解だった、疑惑。> 儂
n: (Thu Apr 20 16:43:19 2006
)
HaskellはLazyだからいいけど、Schemeだとどうするんだろ。call/cc ?
2006-04-19 [Postfix] Postfixでデーモンを動かさずsendmail互換コマンドで送信だけしたい
結論から言うとPostfixではデーモンが動いていなければ送信できない。
この場合Nullクライアントという設定をする。 Postfixデーモンは動くが、port 25は閉じたままになる。 master.cf(一部)は次の通り。 smtdpの行をコメントアウトする。qmngrの行はそのまま生かす。
# ========================================================================== # service type private unpriv chroot wakeup maxproc command + args # (yes) (yes) (yes) (never) (50) # ========================================================================== #smtp inet n - - - - smtpd #628 inet n - - - - qmqpd pickup fifo n - - 60 1 pickup cleanup unix n - - - 0 cleanup qmgr fifo n - - 300 1 qmgr #qmgr fifo n - - 300 1 nqmgr rewrite unix - - - - - trivial-rewrite bounce unix - - - - 0 bounce defer unix - - - - 0 bounce flush unix n - - 1000? 0 flush smtp unix - - - - - smtp showq unix n - - - - showq error unix - - - - - error local unix - n n - - local virtual unix - n n - - virtual lmtp unix - - n - - lmtp
master.cf書き換え後にpostfixをrestartする。たとえばDebian GNU/Linuxでは以下を実行する。
sudo /etc/init.d/postfix restart
--yasuyuki
There is no comment.
2006-04-18 [Haskell] f (f x) ==> -x
f :: Double -> Double
f x | x == 0 = x
| abs x < 1 = negate (recip x)
| abs x == 1 = x / 0
| isInfinite x = negate (signum x)
| otherwise = recip x
1/x = ∞を使うのが味噌？
実行例
*Main> f (f 0) 0.0 *Main> f (f 0.5) -0.5 *Main> f (f (f (f 0.5))) 0.5 *Main> f (f 1) -1.0 *Main> f (f (f (f 1))) 1.0 *Main> f (f 1.5) -1.5 *Main> f (f (f (f 1.5))) 1.5
--nobsun
ひらっち: (Tue Apr 18 11:46:22 2006
)
無限大は実数ではない！とか言ってみる
nobsun: (Tue Apr 18 11:52:35 2006
)
が〜ん。Double(IEEE) は実数ということで勘弁してぇ
[1..100]>>=pen: (Tue Apr 18 12:09:35 2006
)
f は奇関数で、{x > 0} = Ａ∪Ｂ、Ａ∩Ｂ=空集合、ＡとＢは一対一対応、というＡ、Ｂを求める問題に帰着されるですね。
nobsun: (Tue Apr 18 17:18:10 2006
)
昨日分への osiire さんのコメントにあるやつのがいいなぁ
これ解にすんの！？: (Tue Apr 18 22:58:58 2006
)
HOLY FUCK!!! 場合分けなしで作ろうと努力した俺の4時間はどこに!?
sumim: (Wed Apr 19 22:37:06 2006
)
osiire さんと同じ方針のもので、場合分けを排除してみました。 http://d.hatena.ne.jp/sumim/20060418/p1
2006-04-17 [quiz] f (f x) ==> -x
ko1 さんに教えてもらった問題．
2 回適用すると元の値の符号を反転した値が返るような， 実数から実数への関数 f を定義せよ．
f (f (x)) = -x
気づけばなぁーんだと思うけど．．．(半時間は考えてしまったというのは内緒^^;)
--nobsun
び: (Mon Apr 17 18:48:34 2006
)
(define (f x) (* x 0.0+1.0i)) わーごめんなさいごめんなさい
nobsun: (Tue Apr 18 09:10:29 2006
)
「実数から実数への関数 f 」^^;
kazuya: (Tue Apr 18 09:51:10 2006
)
f x = - abs x っていうのはずるいですか?
kazuya: (Tue Apr 18 09:53:09 2006
)
あ、ぜんぜん勘違いしてました…
ひらっち: (Tue Apr 18 11:43:36 2006
)
g を R から (-π, π) への一対一関数とする。(tanなどを使って定義できる) f' = sin^-1(sin(x) + π/2) とすると f = g^-1 o f' o g で合ってるかな？
ひらっち: (Tue Apr 18 11:49:51 2006
)
あ、一対一じゃなかった。無限大は実数ではない、ということを考慮すると。 正確な定義はメンドいのでやめとく(^^;
ひらっち: (Tue Apr 18 13:19:39 2006
)
って、よく考えたらダメダメですね。失礼しました。
osiire: (Tue Apr 18 13:21:00 2006
)
let f x =
if mod_float (floor x) 2.0 = 0.0 then
x -. 1.0
else
-.(x +. 1.0)
osiire: (Tue Apr 18 13:31:05 2006
)
あっ、奇数だめ。失礼しました。
osiire: (Tue Apr 18 15:30:21 2006
)
let is_even x =
let i = if x > 0.0 then floor else ceil in
mod_float (i x) 2.0 = 0.0
let oe b x =
if b then
x +. 1.0
else
x -. 1.0
let f x =
if is_even x then
oe (x > 0.0) x
else
-.(oe (x <= 0.0) x)
nobsun: (Tue Apr 18 17:13:14 2006
)
これ↑Haskellで書くと
f :: Double -> Double
f x | x == 0 = 0
| x > 0 = if odd (ceiling x) then x + 1 else negate (x - 1)
| otherwise = if odd (floor x) then x - 1 else negate (x + 1)
てな感じですか。
yoriyuki: (Tue Apr 18 21:02:00 2006
)
選択公理を使って存在だけ証明した私(実話)
koguro: (Tue Apr 18 22:18:23 2006
)
こんないんちきもありでしょうか?
(define-syntax f
(syntax-rules (f)
((_ (f x)) (- x))
((_ x) x)))
いんちきその2 (効率が悪いですが...)
(define f (let ((lst '((0 0 0 0 0))))
(lambda (x)
(or (and-let* ((elem (find (cut member x <>) lst)))
(cadr (member x elem)))
(let loop ((cnt 1))
(if (and (not (= cnt x))
(not (find (cut member cnt <>) lst)))
(begin
(push! lst (list x (- cnt) (- x) cnt x))
(f x))
(loop (+ cnt 1))))))))
無理やり1行で: (Fri Apr 21 19:17:04 2006
)
f x = -2.0 * x * (-0.25) ^ mod (exponent x) 2
通行人: (Mon May 1 23:00:33 2006
)
ここでの条件を満たすような f で微分可能(もしくは連続)なものは存在するか、存在するならば例をあげ、しないのならばその証明を書け。
2006-04-14 [Haskell] リストの尻尾を交換する(ワケワカ編)
splits なしで書いてみた． Haskellでは大抵の場合スッキリ書けるんだけど．．．
変な色気を出すとワケワカなプログラムになる．
プログラムは弄ってワケワカにしてしまった典型．このプログラムは 書いた当人(あんたのことだよ．> 儂)さえ，正しいんだか正しくないんだか 分りゃしないんだ．orz
import Control.Monad
import Data.Maybe
type Pred a = a -> Bool
swapTail :: Pred a -> Pred a -> [[a]] -> [[a]]
swapTail p q lls = case swapLs p q lls of [] -> lls; l':_ -> l'
swapLs :: Pred a -> Pred a -> [[a]] -> [[[a]]]
swapLs _ _ [] = []
swapLs p q xxs@(x:xs)
= case break2 p q x of
[] -> map (x:) (swapLs p q xs)
x' -> do { (r,ys,zs) <- x'
; (jzs,xs') <- return $ subst r zs xs
; guard (isJust jzs)
; case jzs of Just zs' -> return $ (ys++zs'):xs'
}
where
subst r zs = foldr (g zs) (Nothing,[]) . s zip (map (break2 r (const False)))
g zs (_,(_,us,vs):_) (_,xs) = (Just vs, (us++zs):xs)
g _ (x,_) (y,xs) = (y , x:xs)
s f g x = f x (g x)
break2 :: Pred a -> Pred a -> [a] -> [(Pred a, [a], [a])]
break2 p q [] = []
break2 p q xxs@(x:xs)
| p x = if q x then [p,q] >>= \ r -> return (r,[],xxs) else return (q,[],xxs)
| q x = return (p,[],xxs)
| otherwise = break2 p q xs >>= \ (r,ys,zs) -> return (r, x:ys, zs)
Hanataniさんオリジナル(2006-04-12のコメント欄) の方が ↑ よりもはるかにスッキリしているし分りやすい．
--nobsun
There is no comment.
2006-04-13 [Haskell] リストの尻尾を交換する(続)
2006-04-12への hanatani さんのコメント
述語の順序で交換が起こったり起こらなかったりするのはちょっとまずい気がします。
Main> swapTail even (>3) [[6,8], [2]] [[6,8],[2]] Main> swapTail (>3) even [[6,8], [2]] [[2],[6,8]]
気付いていなかった．orz いただいたコードも恰好よかったので少し弄ってみた．
type Pred a = a -> Bool
swapTail :: Pred a -> Pred a -> [[a]] -> [[a]]
swapTail p q ls = case concat $ f ls of [] -> ls; (x:_) -> x
where
f zs = splits zs >>= \ (xs,y:ys) ->
splits ys >>= \ (vs,w:ws) ->
break2 p q y >>= \ (r,y1,y2) ->
case y2 of
[] -> return []
_ -> case break r w of
(_,[]) -> return []
(w1,w2) -> return [xs ++ [y1 ++ w2] ++ vs ++ [w1 ++ y2] ++ ws]
break2 :: Pred a -> Pred a -> [a] -> [(Pred a, [a], [a])]
break2 p q [] = []
break2 p q xxs@(x:xs)
| p x = if q x then [p,q] >>= \ r -> return (r,[],xxs) else return (q,[],xxs)
| q x = return (p,[],xxs)
| otherwise = break2 p q xs >>= \ (r,ys,zs) -> return (r, x:ys, zs)
splits [] = []
splits x@[_] = [([],x)]
splits xxs@(x:xs) = ([], xxs):[(x:ys, zs) | (ys, zs) <- splits xs]
ううむ．splits なしで行けそうな気がするんだが．．．
--nobsun
There is no comment.
2006-04-12 [Haskell] リストの尻尾を交換する．
2006-04-11ではひとつのリストの中の要素を交換したけど， 複数のリストで尻尾を交換するというのを考えてみた．
swapTail :: (a -> Bool) -> (a -> Bool) -> [[a]] -> [[a]]
swapTail _ _ [] = []
swapTail p q lls@(l:ls)
= case break2 p q l of
Left (_ ,[]) -> l : swapTail p q ls
Left (xs,ys) -> case subst q ys ls of
(Nothing,_ ) -> lls
(Just zs,ls') -> (xs++zs) : ls'
Right (xs,ys) -> case subst p ys ls of
(Nothing,_ ) -> lls
(Just zs,ls') -> (xs++zs) : ls'
subst :: (a -> Bool) -> [a] -> [[a]] -> (Maybe [a],[[a]])
subst _ _ [] = (Nothing, [])
subst p tl lls@(l:ls) = case break p l of
(_,[]) -> case subst p tl ls of
(Nothing,_ ) -> (Nothing, lls )
(tl' ,ls') -> (tl' , l:ls')
(xs,ys) -> (Just ys, (xs++tl):ls)
break2 :: (a -> Bool) -> (a -> Bool) -> [a] -> Either ([a],[a]) ([a],[a])
break2 _ _ [] = Left ([],[])
break2 p q xxs@(x:xs) | p x = Left ([],xxs)
| q x = Right ([],xxs)
| otherwise = case break2 p q xs of
Left (_,[]) -> Left (xxs,[])
Left (ys,zs) -> Left (x:ys,zs)
Right (ys,zs) -> Right (x:ys,zs)
実行例は
pAND p q x = if p x then q x else False test = map (take 10) [[0..],[0,2 ..],[1,3 ..]]
を追加定義して，
*Main> test [[0,1,2,3,4,5,6,7,8,9],[0,2,4,6,8,10,12,14,16,18],[1,3,5,7,9,11,13,15,17,19]] *Main> swapTail (even `pAND` (5<)) (odd `pAND` (10<)) test [[0,1,2,3,4,5,11,13,15,17,19],[0,2,4,6,8,10,12,14,16,18],[1,3,5,7,9,6,7,8,9]]
リストを辿るのを減らすためにあれこれやったのだけど，もっと恰好よくなる と思う．
求む！恰好いい実装！
--nobsun
[1..100]>>=pen: (Wed Apr 12 21:19:55 2006
)
取りあえず短くしてみた
swapTail _ _ [] = []
swapTail _ _ ls@[l] = ls
swapTail p q lls@(l:ls) = case break2 p q l of
Nothing -> l : swapTail p q ls
Just (r,xs,ys) -> let
(v,ls') = subst ls
subst [] = (Nothing, [])
subst (m:ms) = case break r m of
(_,[]) -> (w, m:ms') where (w, ms') = subst ms
(as,bs) -> (Just bs, (as++ys):ms)
in (case v of; Just zs -> (xs++zs):ls'; Nothing -> lls)
break2 _ _ [] = Nothing
break2 p q xxs@(x:xs) | p x = Just (q,[],xxs)
| q x = Just (p,[],xxs)
| otherwise = break2 p q xs >>= (\(r,ys,zs) -> Just(r,x:ys,zs))
hanatani: (Thu Apr 13 01:30:35 2006
)
述語の順序で交換が起こったり起こらなかったりするのはちょっとまずい気がします。 Main> swapTail even (>3) [[6,8], [2]] [[6,8],[2]] Main> swapTail (>3) even [[6,8], [2]] [[2],[6,8]]
hanatani: (Thu Apr 13 02:58:27 2006
)
swapTail p q ls = case concat $ f ls of [] -> ls; (x:_) -> x
where
f zs = do (xs, y:ys) <- splits zs
(vs, w:ws) <- splits ys
case (break p y, break q w, break q y, break p w) of
((y1, y2@(_:_)), (w1, w2@(_:_)), _, _) ->
return [xs ++ [y1 ++ w2] ++ vs ++ [w1 ++ y2] ++ ws]
(_, _, (y1, y2@(_:_)), (w1, w2@(_:_))) ->
return [xs ++ [y1 ++ w2] ++ vs ++ [w1 ++ y2] ++ ws]
_ -> return []
splits [] = [([], [])]
splits xxs@(x:xs) = ([], xxs):[(x:ys, zs) | (ys, zs) <- splits xs]
nobsun: (Thu Apr 13 07:32:55 2006
)
述語の順序依存か。うっかりしてました。 たまにやってしまいます。パタンやガードの順序依存。。。orz
2006-04-11 [Haskell] リストの要素の交換
述語 p を満す最初の要素と述語 q を満す最初の要素を交換する． (最初に見つかった要素が p， q ともに満す場合はもうひとつ別の 要素を探すものとする．2006-04-12): 追記)
swap :: (a -> Bool) -> (a -> Bool) -> [a] -> [a]
swap p q [] = []
swap p q xxs@(x:xs) | p x = case break q xs of
(ys,z:zs) -> z:(ys++x:zs)
_ -> xxs
| q x = case break p xs of
(ys,z:zs) -> z:(ys++x:zs)
_ -> xxs
| otherwise = x:swap p q xs
- コード改変 2006-04-12
--nobsun
There is no comment.
2006-04-10 [tarai] たらいまわし再び
定期的に話題になるのかなぁ．
今回は(たらいを回すならHaskell)が原発かなぁ．
Haskellでは
tarai x y z | x < y = y
| otherwise = tarai (tarai (x-1) y z)
(tarai (y-1) z x)
(tarai (z-1) x y)
Scheme では
(define (tarai x y z)
(if (< x y)
y
(tarai (tarai (- x 1) y z)
(tarai (- y 1) z x)
(tarai (- z 1) x y))))
というシンプルな関数
Haskellが速いのは，この関数が第三引数に関して正格ではない(non-strict)， つまり，常に第三引数を評価する必要がないという性質をもつためである． このような非正格関数の評価については，式を必要になるまで評価しないlazy evaluationで評価する言語が有利なのである．
そのもっとも顕著な例がこの tarai です．
このtarai関数の場合，関数適用の評価履歴を引数をキーにしてキャッシュ する方法(memoisation)を使っても lazy ほどの劇的効果はでません．
Haskellではふつうにmemoiseしようとすると却って劇的に遅くなります． 引数をKeyにしてテーブルを引こうとすると第三引数を評価せざるをえない ので，lazy が egar になってしまうから．
--nobsun
There is no comment.
2006-04-07 [Gauche] Rose tree のサブツリーの置き換え
2006-04-05を少しわかりやすくした(つもり ^^;)
('Rose <content> <children>)
<content>部分が述語 p を満すサブツリーを new で置き換える．
(define (substitute-rose-tree p tree new)
(let1 content (rose-tree-content tree)
(if (p content)
new
(let1 children (rose-tree-children tree)
(rose-tree content
(map (cut substitute-rose-tree p <> new) children))))))
--nobsun
えんどう: (Tue Apr 11 17:02:29 2006
)
ええっと、newは「新たな子の並び」ではなく新たな部分木('Rose <content> <children>)ですね?
nobsun: (Wed Apr 12 08:38:45 2006
)
あぅ。そうです。問題をよみちがえてた。
2006-04-06 [JavaScript] script.aculo.usを使った項目入れ替え時のイベント通知(改定版)
2006-03-31のコードはscript.aculo.us 1.6では動作するが、1.6.1ではうまく動作しない。
script.aculo.us 1.6.1で動作させるためには以下の通りに書き換える。
<html>
<head>
<script type="text/javascript" language="javascript" src="prototype.js"></script>
<script type="text/javascript" langupage="javascript" src="scriptaculous.js"></script>
</head>
<body>
<div id="book">
<div id="chap_1">- Foundations of Ajax</div>
<div id="chap_2">- Using XMLHttpRequest Object
<div id="sec_1">-- Overview of the XMLHttpRequest Object</div>
<div id="sec_2">-- Methods and Properties</div>
<div id="sec_3">-- An Example Interaction</div>
</div>
<div id="chap_3">- Communicating with the Server</div>
</div>
<script type="text/javascript" language="javascript">
Sortable.create('chap_2',{tag:'div',ghosting:false,constraint:false,
onUpdate:function(s){alert(Sortable.serialize(s))}});
Sortable.create('book',{tag:'div',ghosting:false,constraint:false,
onUpdate:function(s){alert(Sortable.serialize(s))}});
</script>
</body>
</html>
要点は、内側のSortableを先に宣言することである。どうして1.6.1からこういう仕様になってしまったのかは不明。
--yasuyuki
There is no comment.
2006-04-05 [Gauche] Rose treeの子要素の順番を入れ替える
2005-10-17の続き。
全体木 tree-data、入れ替え対象の部分木の先頭 content、 部分木の子の新しい並び new-children が与えられているとする。
置き換え後の全体木は以下で得られる。
(let replace-rose-tree
((t tree-data))
(rose-tree (rose-tree-content t)
(map (lambda (child) (replace-rose-tree child))
(if (equal? content (rose-tree-content t))
new-children
(rose-tree-children t)))))
もっとエレガントな解があるに違いないが、 とりあえず動いているので良しとする。＜ぉ
--yasuyuki
There is no comment.
2006-04-04 [MacOS] MacOS 10.4でqpopperを動かす
http://routine.dip.jp/pukiwiki/?Mac%20mini
上記を参考に、MacOS 10.4でqpopperを動かしてみる。
まずqpopperのソースコードを下記からダウンロードする。
http://www.eudora.com/products/unsupported/qpopper/index.html
これを書いている時点での最新版はqpopper4.0.9である。
ダウンロードしたソースファイルを展開し、展開後のディレクトリqpopper4.0.9に移動する。
tar xvfz qpopper4.0.9.tar.gz cd qpopper4.0.9
./configureに--with-pam=pop3オプションを付けて実行しmakeする。
./configure --with-pam=pop3 make
makeが完了したらインストールする。
sudo make istall
イストール後には/usr/local/sbin/popperという実行ファイルがインストールされているはずである。
PAM認証を有効にするため、/etc/pam.d/sshファイルを/etc/pam.d/pop3というファイル名でコピーする。
sudo cp /etc/pam.d/ssh /etc/pam.d/pop3
/System/Library/LaunchDaemons/pop3.plist というファイルをルート権限で作成し、次の通りに編集する。
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>Label</key>
<string>com.qualcomm.qpopper</string>
<key>ProgramArguments</key>
<array>
<string>/usr/local/sbin/popper</string>
</array>
<key>inetdCompatibility</key>
<dict>
<key>Wait</key>
<false/>
</dict>
<key>Sockets</key>
<dict>
<key>Listeners</key>
<dict>
<key>SockServiceName</key>
<string>pop3</string>
</dict>
</dict>
</dict>
</plist>
念のためOSを再起動してみる。
再起動後、認証できるかどうかtelnetでテストしてみる。
$ telnet localhost 110 Trying ::1... Connected to localhost. Escape character is '^]'. +OK Qpopper (version 4.0.9) at janet.local starting.
qpopperが動作しているようだ。 このMacOSに存在するアカウントをUSERコマンドの次に空白をはさんで入力してみる。
USER humuhumu +OK Password required for humuhumu.
ユーザー名humuhumuは認識されているようだ。 PASSコマンドの次に空白をはさんでログインパスワードを入力してみる。
PASS nukunuku +OK humuhumu has 0 visible messages (0 hidden) in 0 octets.
パスワードは認証されているようだ。 QUITコマンドで終了してみる。
QUIT +OK Pop server at janet.local signing off. Connection closed by foreign host.
qpopperはQUITコマンドで正常に終了した。
--yasuyuki
There is no comment.
2006-04-03 [MacOS] MacOS 10.4でPostfixを動かす
http://blog.livedoor.jp/dankogai/archives/20511234.html
上記を参考に作業。
/etc/postfix/main.cf /etc/postfix/master.cf
上記はすでに存在したのでそのまま使用したが、 実運用に際してはhttp://www.kobitosan.net/ などを参考に適宜修正が必要である。
/System/Library/LaunchDaemons/org.postfix.master.plist
上記を以下の通りに編集。
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
<key>Label</key>
<string>org.postfix.master</string>
<key>Program</key>
<string>/usr/libexec/postfix/master</string>
<key>ProgramArguments</key>
<array>
<string>master</string>
</array>
<key>QueueDirectories</key>
<array>
<string>/var/spool/postfix/maildrop</string>
</array>
<key>OnDemand</key>
<false/>
</dict>
</plist>
launchctlで起動させる
sudo launchctl stop org.postfix.master sudo launchctl start org.postfix.master
telnetで動作確認を行う。
$ telnet localhost 25 Trying ::1... telnet: connect to address ::1: Connection refused Trying 127.0.0.1... Connected to localhost. Escape character is '^]'. 220 janet.local ESMTP Postfix
ポート25でPostfixが動作しているようだ。
QUIT
QUITと入力して終了してみる。
221 Bye Connection closed by foreign host.
正常終了した。
--yasuyuki
There is no comment.
There is no comment.