codejamの過去問でcommon lispの練習2

問題は2013のqualification round B

結果用の高さ100の芝生を用意して、入力される刈り込みたい候補案を高さ100のものに適用する
適用は、入力縦横一行取り出して、その一行の一番高いものを結果用に当てはめる
当てはめる際に入力より高い場合は入力値に合わせる
すでに入力より低い場合はそのまま
縦横当てはめて結果用と入力が同じかどうか判定

(defmacro form1(x) `(format t "~A~%" ,x))

(defun repeat(x n)
  (labels ((rec(i acc)
    (if (= i n)
      acc
      (rec (1+ i) (cons x acc)))))
 (rec 0 nil)))

(defun range(n)
  (labels ((rec(i acc)
    (if (= i n)
      (reverse acc)
      (rec (1+ i) (cons i acc)))))
 (rec 0 nil)))

(defun readstream(callback)
  (labels ((rec(n)
    (let ((line (read-line *standard-input* nil)))
      (when line
     (funcall callback line n)
     (rec (1+ n))))))
 (rec 0)))

(defun parseNM(line)
  (read-from-string (format nil "(~A)" line)))

(defun maxval(lst)
  (reduce #'max (cdr lst) :initial-value (car lst)))

(defun toverticalvals(lst)
  (mapcar (lambda(i)
   (reduce (lambda(r x) (max r (nth i x))) (cdr lst) :initial-value (nth i (car lst))))
 (range (length (car lst)))))

(defun applyverticalvals(lst vlst)
  (mapcar (lambda(r) (mapcar #'min r vlst)) lst))

(defun compute(in)
  (labels ((rec(in acc)
    (if (null in)
      (reverse acc)
      (rec (cdr in) (cons (repeat (maxval (car in)) (length (car in))) acc)))))
 (equal in (applyverticalvals (rec in nil) (toverticalvals in))))
  )

(defun test()
  ;(form1 (toverticalvals '((2 1 2) (1 8 1) (2 1 3))))
  ;(form1 (range 10))
  ;(form1 (maxval '(8 7 6 5 4 3 2)))
  )
(test)

(let ((in nil)
   (no_of_problem 0)
   (problemindex 0)
   (size '(1 0))
   (nextsizeindex 1)
   (messagelut '((t . "YES") (nil . "NO"))))
  (readstream (lambda(line n)
    ;(format t "~A ~A ~A~%" n nextsizeindex line)
    (cond ((zerop n) (setf no_of_problem (read-from-string line)))
       ((= n nextsizeindex) (incf problemindex) (setf size (parseNM line)) (setf nextsizeindex (+ nextsizeindex (car size) 1)) (setf in nil))
       (t (setf in (cons (parseNM line) in)) (when (= n (1- nextsizeindex))
                 (format t "Case #~A: ~A~%" problemindex (cdr (assoc (compute (reverse in)) messagelut)))))
       )
    )
     )
  )

codejamの過去問でcommon lispの練習

codejamの季節が近づいてきたのでcommon lispの練習をしました
問題は2013のqualification round

まずA
入力をアトムへ置き換えて横向きのリストで格納して、さらに縦向きのリストと斜めのリストを作ってX,Oどちらかが勝っている状態があるか検索
とりあえず横向きで検索、見つからなかったら縦向きで検索、さらに見つからなかったら斜めで検索
X,Oどちらの勝利状態も見つからない場合引き分けかどうか判定
マクロの練習として、縦向きのリストの作成をマクロで展開してみました
例えば将棋やオセロなんかのプログラムだとリストを走査する際にループじゃなくていちいち展開しているっぽいなと思ったので、一度マクロで試してみたかったので無理やりマクロ使いましたが結果はいいのか悪いのか不明
プログラムが分かりにくくなったのはとりあえず分かる

(defun readstream(callback)
  (labels ((rec(n)
    (let ((line (read-line *standard-input* nil)))
      (when line
     (funcall callback line n)
     (rec (1+ n))))))
 (rec 0)))

(let ((a '(0 1 2 3)))
  (defun tosymb(line)
 (mapcar (lambda(n) (read-from-string (substitute #\B #\. line) nil nil :start n :end (1+ n))) a))
  (defmacro tocross(lst)
 `(list
    (list ,@(mapcar (lambda(n) `(nth ,n (nth ,n ,lst))) a))
    (list ,@(mapcar (lambda(n) `(nth (- 3 ,n) (nth ,n ,lst))) a))
    ))
  (defmacro tovertical(lst)
 `(list
    ,@(mapcar (lambda(m)
     (cons 'list (mapcar (lambda(n) `(nth ,m (nth ,n ,lst))) a))
     ) a)
    )
 )
  (defun makelst(b n)
 (mapcar (lambda(m) (if (= n m) 't b)) a))

  (defmacro searcher(lst v)
 `(let ((target ',(mapcar (lambda(n) (makelst v n)) a)))
    (labels ((rec(ta)
      (cond ((null ta) nil)
      ((equal (car ta) ,lst) ',v)
      (t (rec (cdr ta))))))
   (rec (cons (list ',v ',v ',v ',v) target))
    )
 ))
  )

(defun hanbetsu(inlst)
  (labels ((rec(lst)
    (cond ((null lst) nil)
       ((searcher (car lst) x) 'x)
       ((searcher (car lst) o) 'o)
       (t (rec (cdr lst))))))
 (rec inlst)))

(defun drawp(lst)
  (labels ((rec(lst)
    (cond ((null lst) 'd)
       ((find 'b (car lst)) 'n)
       (t (rec (cdr lst))))))
 (rec lst)))

(defmacro ifelse(pred else)
  `(let ((r ,pred))
  (if r
    r
    (progn ,else))))

(defun test()
  (let ((lst '((a b c d) (e f g h) (i j k l) (m n o p))))
 (format t "~A~%" (macroexpand-1 '(ifelse (hanbetsu (tocross in)) (lambda()))))
 ;(format t "~A~%" (drawp '((a z c d e))))
 ;(format t "~A~%" (mapcar (lambda(n) (makelst 'x n)) '(0 1 2 3)))
 ;(format t "~A~%" (macroexpand-1 '(searcher (car lst) x)))
 ;(format t "~A~%" (hanbetsu '((x x t x))))
 ;(format t "~A~%" (macroexpand-1 '(tocross lst)))
 ;(format t "~A~%" (tocross lst))
 ;(format t "~A~%" (macroexpand-1 '(tovertical lst)))
 ;(format t "~A~%" (tovertical lst))
 (format t "~%~%")
 ))
;(test)

(defun compute(in)
  (ifelse (hanbetsu (tocross in))
    (ifelse (hanbetsu (tovertical in))
      (ifelse (hanbetsu in)
        (drawp in)))))

(let ((in nil)
   (index 0)
   (messagelut '((x . "X won") (o . "O won") (d . "Draw") (n . "Game has not completed"))))
  (readstream (lambda(line n)
    (cond ((zerop (rem n 5)) (setf in nil) (incf index))
    ((= (rem n 5) 4)
     (progn
    (setf in (cons (tosymb line) in))
    (format t "Case #~A: ~A~%" index (cdr (assoc (compute (reverse in)) messagelut)))
    ))
    (t (setf in (cons (tosymb line) in)))))
  )
  )

Haskellでcode jamに挑戦 2013予選C

予選C
実際調べてみたら、1e14までなら対象の数が数十個なので一旦数十個見つけ出してあとは入力範囲内にその数十個からあるだけ数えるでLarge input 1は解けました

が、Large input 2は対象の数が多すぎて1e100ってどうやって調べるかまったく見当もつかない状態でギブアップです



これも本番時はどうしてもIntとIntegerとFloatingの変換でうまく動かず
と言うか、動く以前にコンパイルすら通すことができず断念


予選Bといい、予選CといいHaskellってまったくいいところなしのクソクズ言語だなって思ってしまいましたが、翌日落ち着いて改めて取り組んでみたらサクサク進んだと言うかやっぱりいい言語なんじゃないかなと言ったところが最終的な結論でしょうか

1e100の入力はどうやってやるか不明のままです

--digitcp c = any (\i -> i == c) ['0'..'9']

pow base n = foldl (*) 1 (take n $ repeat base)

--rInt s = read (takeWhile digitcp s) :: Integer
rInt s = read s :: Integer

check lower upper = let lowersqrt = (ceiling . sqrt)
   uppersqrt = (truncate . sqrt)
   rr = [(lowersqrt (lower::Double))..(uppersqrt (upper::Double))]
   tostr = map show
   z arr = zip (tostr arr) ((map reverse . tostr) arr)
   filterpalindrome arr = (map (rInt . fst) . filter (\(a, b) -> a == b) . z) arr
   in
   (map (rInt . fst) . filter (\(a, b) -> a == b) . z) (map (\x -> x * x) $ filterpalindrome rr)
   --(length . filter (\(a, b) -> a == b) . z) (map (\x -> x * x) $ filterpalindrome rr)

start = check (pow 10 14) (pow 10 15)
st n = check (pow 10 n) (pow 10 (n + 1))
format n m = "Case #" ++ show n ++ ": " ++ show m

parserec _ [] = []
parserec n lines = let lower = (rInt . head . words . head) lines
         upper = (rInt . last . words . head) lines
         in
         (format (n + 1) (check (fromIntegral lower) (fromIntegral upper))) : (parserec (n + 1) . tail) lines

parserec_large1 _ _ [] = []
parserec_large1 n res lines = let lower = (rInt . head . words . head) lines
      upper = (rInt . last . words . head) lines
      in
      ((format (n + 1) . length . filter (\i -> and [(i >= lower), (i <= upper)])) res) : (parserec_large1 (n + 1) res . tail) lines

parse lines = let t = (rInt . head) lines
    in
    (parserec 0 . tail) lines

parse_large1 lines = let t = (rInt . head) lines
    res = check 1 (pow 10 14)
    in
    (parserec_large1 0 res . tail) lines

main = do cs <- getContents
   (putStr . unlines . parse_large1 . lines) cs

Haskellでcode jamに挑戦 2013予選B

予選B
とりあえず入力に近づくように刈れるだけ刈ってみる
縦横m*n回できるかぎり入力のように刈ってみて入力と比較して結局一緒になっているかどうかで可能かどうか判定

特に困るところはなくsmallもlargeも解けた




と言いたいところなんですけど、どっか間違えていてなぜかincorrect判定
で直せない、直す気力がなかったです
アルゴリズム的には絶対合っている自信があったので次の日再度プログラム組んでみたらやっぱり正解でした
と言うことで公式記録としては点数として残りませんでした

やっぱり本番だろうと動揺せずに冷静に取り組めるようになるためにも練習とか大事だなと思いましたね
って言うかこの時点では本当に入力データのパースに参っていて何やってるかさっぱり訳わかんない状態だったからね
自分で考えてHaskellのプログラムしたのは去年のcode jam以来だと思うので
って言うか去年も数問解けたのあるのですけど本当、自分でやっておいてまったく信じられないからね
よくHaskellで問題が解けたな去年の俺って感じですから

あと次の日落ち着いて練習のつもりで気楽にやってみたら入力文字のパースも簡単な方法がわかってなんか拍子抜けな感じ
takeとdropと再帰とwordsでこんなにも簡単にパースできるなんて昨日の苦労はなんだったんだろうかと感じております

org n = take n $ repeat 100

f rows cols ans = let size = rows * cols
        inrow n i = and [i >= n * cols, i < ((n + 1) * cols)]
        incol n i = (i `mod` cols) == n
        setrowval nth n = map (\i -> if inrow nth i then n else 0) [0..(size - 1)]
        setcolval nth n = map (\i -> if incol nth i then n else 0) [0..(size - 1)]
        mergeifnotzero = zipWith (\a  b -> if b /= 0 then (min a b) else a)
        rowvals nth = zipWith (\a b -> if inrow nth a then b else 0) [0..]
        colvals nth = zipWith (\a b -> if incol nth a then b else 0) [0..]
        computerow ans input nth = mergeifnotzero input $ setrowval nth ((maximum . rowvals nth) ans)
        computerows ans input = foldl (computerow ans) input [0..rows-1]
        computecol ans input nth = mergeifnotzero input $ setcolval nth ((maximum . colvals nth) ans)
        computecols ans input = foldl (computecol ans) input [0..cols-1]
        compute ans = (computerows ans . computecols ans . org) (rows * cols)
        in
        compute ans

rInt s = read s :: Int
resformat n b
  | b = "Case #" ++ show n ++ ": YES"
  | otherwise = "Case #" ++ show n ++ ": NO"

parseItem _ [] = []
parseItem n lines = let rows = (rInt . head . words . head) lines
   cols = (rInt . last . words . head) lines
   ls = (take rows . drop 1) lines
   ans = (map rInt . words . unlines) ls
   res = f rows cols ans
   in
   ((resformat (n + 1) . and) $ zipWith (==) ans res) : (parseItem (n + 1) . drop (rows + 1)) lines

parse lines = let t = (rInt . head) lines
    in
    (parseItem 0 . tail) lines

main = do cs <- getContents
   (putStr . unlines . parse . lines) cs

Haskellでcode jamに挑戦 2013予選A

2013年のcode jamに懲りずにまたまたHaskellで挑戦しました

Land of Lisp読んだばっかりだからやっぱりCommon Lispでやりたかったけど結局code jamみたいな数値計算系はHaskellの方が有利かなと思ってHaskellで挑戦しました
結局、入力のパースで散々な目にあいましたが

予選A
Xを+1、Oを-1、Tを2倍にするとして+3を上回るか-3を下回るものがあるか検索
+3を上回るか-3を下回るものが見つかったら終了
見つからなかったら「.」を検索してあったら途中、なかったら引き分けとして決着
注意点はTの2倍を最後に回すように気をつけてsmall、largeともにクリアできました

HaskellらしくX,O,Tの処理を関数の部分適応で対応したところがHaskellらしいのではないかなと思っております

しかし本題に取り組むよりも入力のパースで手間取りました
Haskellで入力をパースしてどうこうするってことをあまりやったことがないからテキストから整数に変換する方法やら入力を成形するところで大幅につまづきました
正直、途中で心が折れるところでした

import Data.List

x = (+1)
t = (*2)
o = (subtract 1)
d = (+0)

input = "xxxt....oo......"
predp 't' _ = GT
predp _ _ = LT

mapf = map f
     where f 'x' = x
    f 't' = t
    f 'o' = o
           f 'X' = x
    f 'T' = t
    f 'O' = o
    f '.' = d
    f _ = d

so = sortBy predp

r n = take 4 . drop (4 * n)
c n xs = foldr (\nn a -> (head $ drop (4 * nn + n) xs) : a) [] [0..3]
lurb xs = foldr f [] [0..3]
     where f 0 a = (head xs) : a
    f 1 a = (head $ drop 5 xs) : a
    f 2 a = (head $ drop 10 xs) : a
    f 3 a = (head $ drop 15 xs) : a
rulb xs = foldr f [] [0..3]
     where f 0 a = (head $ drop 3 xs) : a
    f 1 a = (head $ drop 6 xs) : a
    f 2 a = (head $ drop 9 xs) : a
    f 3 a = (head $ drop 12 xs) : a
app = foldl (\n x -> x n) 0

inputs = map (app . mapf . so) $ (map (\n -> r n input) [0..3]) ++ (map (\n -> c n input) [0..3]) ++ [(lurb input)] ++ [(rulb input)]
inlist i = map (app . mapf .so ) $ (map (\n -> r n i) [0..3]) ++ (map (\n -> c n i) [0..3]) ++ [(lurb i)] ++ [(rulb i)]

rInt s = read s :: Int

res [] s n
  | any (=='.') s = "Case #" ++ show n ++ ": Game has not completed"
  | otherwise = "Case #" ++ show n ++ ": Draw"
res (x:xs) s n
  | x > 3 = "Case #" ++ show n ++ ": X won"
  | x < -3 = "Case #" ++ show n ++ ": O won"
  | otherwise = res xs s n

main = do cs <- getContents
   putStr $ unlines $ map (\(s, m) -> res (inlist s) s (m + 1)) $ map (\n -> (foldl (++) "" $ take 4 $ drop ((n * 5) + 1) $ lines cs, n)) [0..((rInt $ head $ lines cs) - 1)]

Code Jamの季節到来

今年こそ予選突破を目指す

最強プログラミング言語のCommon Lispを味方につけて予選突破をめざす
我ながらなんて低い目標なのかと悲しくなってきますが身の程をわきまえるとこの程度の実力しか有していないから仕方がないですね
大体、英語の問題の時点でかなり苦痛を強いられてしまうから悲しいです
出題文の英語がね
とりあえず問題の意味がわかるかどうかにかかっていますが
予選程度の問題だったら日本語で出題されたらわかるのかな？
いままでの実績だとsmallは解けるんだよな
でもlargeがダメなんだよね

Google Code Jam練習問題

2011の予選問題に挑戦

Problem C.

相変わらず問題の意味は良く分からないですがとりあえずxorすればいいのかなってことで解きました
xorでまとめただけです

(defun compute (lst)
  (if (zerop (reduce #'logxor lst))
    (reduce #'+ (cdr (sort lst #'<)))
    "NO"))

(dotimes (i (read))
  (let ((r nil))
    (dotimes (j (read))
      (setf r (cons (read) r)))
    (format t "Case #~A: ~A~%" (1+ i) (compute (nreverse r)))))

Google Code Jam練習問題

Google Code Jam 2012のエントリー受付中なので早速登録しました
Lisper目指してますので回答はCommon Lispで挑戦していきます
事前準備と言うことで練習問題に挑戦しました

2011の予選問題に挑戦

Problem A.
は問題のまま素直にプログラム組むとターンで繰り返すようになりますが、そうすると遅そうなので距離をまとめて引き算して次のスイッチの距離までを一気に計算するようにしました
BなのかOなのかの判断がイマイチ野暮ったい回りくどい記述になっているなと思います
この辺りをなんとかするともう少しスッキリしたものになるんじゃないかなと

(defun operate (input)
  (labels ((getrobot (lst) (car (car lst)))
    (getdistance (lst) (cdr (car lst)))
    (getnextpos (robot lst) (if (assoc robot lst) (cdr (assoc robot lst)) 0))
    (getdiff (pos lst) (abs (- pos (getdistance lst))))
    (getpos (pos target dist)
     (cond ((< pos target) (if (< (+ pos dist) target) (+ pos dist) target))
    (t (if (< (- pos dist) target) target (- pos dist)))))
    (rec (lst bpos opos turn)
  (cond ((null (cdr lst))
         (if (eq 'b (getrobot lst))
    (+ turn (getdiff bpos lst))
    (+ turn (getdiff opos lst))
    ))
        ((eq 'b (getrobot lst))
         (let ((diff (getdiff bpos lst)))
    (rec (cdr lst) (getdistance lst) (getpos opos (getnextpos 'o lst) (1+ diff)) (1+ (+ turn diff)))))
        (t
   (let ((diff (getdiff opos lst)))
     (rec (cdr lst) (getpos bpos (getnextpos 'b lst) (1+ diff)) (getdistance lst) (1+ (+ turn diff)))))
        )
  )
    )
    (rec input 1 1 1)
    )
  )

(dotimes (i (read) i)
  (let ((r nil))
    (dotimes (j (read) j)
      (setf r (cons (cons (read) (read)) r)))
    (format t "Case #~A: ~A~%" (1+ i) (operate (nreverse r)))))

Problem B.
は問題の意味が分からない
英語が辛いです