プログラミング:企画もの:お題2

お題２「縦型カレンダーを作る」...
縦書きカレンダーは...
Haskell版(縦横対応)...
それにしてもMonad......
Squeak 3.2 版 (ある意味、縦横対応版)...
「カレンダー」Squeak 3.2 向き自在版（Squeak 3.2 版 (ある意味、縦横対応版) (#5)へ追加）...
GikoForth版（縦、GikoForth版 (プログラミング:企画もの:お題１)に対する差分）...

お題２「縦型カレンダーを作る」

お題「カレンダーを作る」 (プログラミング:企画もの:お題１)とほぼ同じ仕様で、日付の並びが

2002/09
Sun 01 08 15 22 29
Mon 02 09 16 23 30
Tue 03 10 17 24
Wed 04 11 18 25
Thu 05 12 19 26
Fri 06 13 20 27
Sat 07 14 21 28

となるようなカレンダー。
※日付の数字は０パディングでなくてもよい。

[[id:1107]] 2002-09-03 00:15:25

縦書きカレンダーは

英語と日本語とアラビア語とモンゴル語のうちどの2つのを選ぶかによって
結構違う"問題"になっちゃうかも。面白い。

[[id:1149]] 2002-09-07 17:54:27

Haskell版(縦横対応)

#!/usr/bin/env runhugs
\begin{code}
module Main where

import List
import System

groupsOf :: Int -> [a] -> [ [a] ]
groupsOf n [] = []
groupsOf n xs = take n xs : groupsOf n (drop n xs)

monthLengths y = [31,feb,31,30,31,30,31,31,30,31,30,31]
where feb | leap y = 29
| otherwise = 28

leap y = if y `mod` 100 == 0 then y `mod` 400 == 0
else y `mod` 4 == 0

jan1st y = (y + last `div` 4 - last `div` 100 + last `div` 400) `mod` 7
where last = y - 1

firstDays y = take 12
(map (`mod` 7)
(scanl (+) (jan1st y) (monthLengths y)))

dates fd ml = map (date ml) [1-fd..42-fd]
where date ml d | d<1 || ml<d = td 0
| otherwise = td d
td 0 = tag "td" [] ""
td d = tag "td" ["align=\"right\""] (show d)

monthnames = ["January","February","March","April","May","June"
,"July","August","September","October","November","December"]

captionline y m = tag "caption" [] (show y ++ " " ++ monthnames !! (mー1))

daynames = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
dayline = map (tag "th" []) daynames

tag t as s = "<" ++ t ++ " " ++ unwords as ++ ">" ++ s ++ "</" ++ t ++ ">"

calendar :: Int -> Int -> (String,[String])
calendar y m
= (capl, dayline ++ dates fd ml)
where
fd = firstDays y !! (m-1)
ml = monthLengths y !! (m-1)
capl = captionline y m

main :: IO ()
main = do { y:m:f <- getArgs
; case calendar (read y) (read m) of
(cap,ss) -> putStr
$ tag "table" []
$ (cap ++)
$ ("\n"++)
$ unlines
$ map (tag "tr" [] . concat)
$ case f of {[]->id;_->transpose}
$ groupsOf 7 ss
}
\end{code}

第一引数年、第二引数月 (ともに必須)
第三引数任意この引数を与えると縦ならびになり、与えないと横ならびになる。

B&Wをカンニングしました。。。
----
しまった。そういう展開もありか… (x_x; --SHIMADA

----
あっ。タトしました？ --Haskeller
- いえいえ合ってます。出題から数時間で解かれてしまったのでびっくりしただけです。（笑 --SHIMADA

[[id:1108]] 2002-09-03 11:25:20

それにしてもMonad...

re: Haskell版(縦横対応) (#3)
calendar まではふんふんなるほど、と読み進められるのに、main になるといきなり分からなくなるよう‥‥‥。 --SHIMADA
----
私も Monad の深層は全然理解していません。--Haskeller
私のなかでは Monad == do 構文ということですませています。main の構造は基本的には

do args <- getArgs
putStr (proc args)

で、getArgs でとってきた引数を args::[String] に束縛して、proc :: [String] -> String で処理して、結果の文字列を putStr で標準出力に出しているだけです。

main = do args <- getArgs
putStr (proc args)

proc args
= case args of
y:m:f -> case calendar (read y) (read m) of
(cap,ss) -> ( tag "table" []
. (cap ++)
. ("\n"++)
. unlines
. map (tag "tr" [] . concat)
. case f of {[]->id;_->transpose}
. groupsOf 7 ) ss

と同じです。

[[id:1110]] 2002-09-03 14:11:15

Squeak 3.2 版 (ある意味、縦横対応版)

長くてすみません。
----
'From Squeak 3.2 of 11 July 2002 [latest update: #4917] on 3 September 2002 at 0:24:48 am'!
Object subclass: #Calendar
instanceVariableNames: 'month '
classVariableNames: ''
poolDictionaries: ''
category: 'Goodies-Calendar'!

!Array2D methodsFor: 'converting' stamp: 'sumim 9/3/2002 11:24'!
asHtmlTable
| htmlTable htmlTableRow |
htmlTable _ HtmlTable new.
1 to: self height do: [ :row |
htmlTableRow _ HtmlTableRow new.
1 to: width do: [ :col |
htmlTableRow addEntity:
(HtmlTableDataItem new addEntity: (HtmlTextEntity new text: (
(self at: col at: row) asString)))].
htmlTable addEntity: htmlTableRow].
^ htmlTable! !

!Array2D methodsFor: 'converting' stamp: 'sumim 9/3/2002 11:04'!
transpose
| array2D |
array2D _ Array2D extent: self height @ self width.
1 to: self height do: [ :row |
array2D atCol: row put: (self atRow: row) ].
^ array2D! !

!Array2D methodsFor: 'copying' stamp: 'sumim 9/3/2002 12:05'!
copy
^ (self class extent: width @ self height) setContents: contents copy! !

!Array2D methodsFor: 'enumeration' stamp: 'sumim 9/3/2002 12:04'!
collect: aBlock
^ self copy setContents: (contents collect: aBlock)! !

!Calendar methodsFor: 'converting' stamp: 'sumim 9/3/2002 12:11'!
asArray2D
| array2D week |
array2D _ Array2D extent: 7 @ self numberOfWeeks.
week _ Week fromDate: month.
1 to: array2D height do: [ :row |
array2D atRow: row put: (week collect: [ :date | date ]).
week _ week next].
^ array2D! !

!Calendar methodsFor: 'converting' stamp: 'sumim 9/3/2002 12:49'!
asStringArray2D
^ self asStringArray2dWithLabelLength: 2 startMonday: false hideOtherMonth: true! !

!Calendar methodsFor: 'converting' stamp: 'sumim 9/3/2002 12:16'!
asStringArray2dWithLabelLength: n startMonday: startMon hideOtherMonth: hideOtherMonth
| array2D savedStartMondayState stringArray2D stringArray2dWithLabel |

savedStartMondayState _ Week startMonday.
startMon == savedStartMondayState ifFalse: [ Week toggleStartMonday ].

stringArray2D _ (array2D _ self asArray2D) collect: [ :date |
(hideOtherMonth not | (date month = self month)) ifTrue: [
date dayOfMonth asString] ifFalse: [''] ].
stringArray2dWithLabel _ Array2D extent: 7 @ (array2D height + 1).
stringArray2dWithLabel atRow: 1 put: ((array2D atRow: 1) collect: [ :date |
date weekday asString copyFrom: 1 to: n ]).
2 to: array2D height + 1 do: [ :row |
stringArray2dWithLabel atRow: row put: (stringArray2D atRow: row - 1)].

startMon == savedStartMondayState ifFalse: [ Week toggleStartMonday ].

^ stringArray2dWithLabel! !

!Calendar methodsFor: 'initializing' stamp: 'sumim 9/3/2002 12:04'!
month: monthIndex year: year
month _ Month month: monthIndex year: year! !

!Calendar methodsFor: 'accessing' stamp: 'sumim 9/3/2002 12:14'!
month
^ month! !

!Calendar methodsFor: 'accessing' stamp: 'sumim 9/3/2002 12:04'!
numberOfWeeks
^ (Week fromDate: month lastDate) indexInMonth: month! !

!Calendar class methodsFor: 'instance creation' stamp: 'sumim 9/3/2002 11:49'!
month: month year: year
^ super new month: month year: year! !

!Calendar class methodsFor: 'instance creation' stamp: 'sumim 9/3/2002 12:06'!
thisMonth
| today |
today _ Date today.
^ super new month: today monthIndex year: today year

"Calendar thisMonth asStringArray2D asHtmlTable asHtml"! !

!Week methodsFor: 'enumerating' stamp: 'sumim 9/3/2002 12:44'!
collect: aBlock
| orderedCollection |
orderedCollection _ OrderedCollection new.
self do: [ :date | orderedCollection addLast: date ].
^ orderedCollection asArray! !

Calendar initialize!
----
Calendar thisMonth asStringArray2D asHtmlTable asHtml "横"
Calendar thisMonth asStringArray2D transpose asHtmlTable asHtml "縦"

(Calendar month: 9 year: 2002) asStringArray2D transpose asHtmlTable asHtml

#Array2D にデフォで transpose があれば一行野郎でやっつけようと思ったのですが、無かったので観念して Calendar クラスを定義しました。--sumim

[[id:1112]] 2002-09-03 14:35:05

「カレンダー」Squeak 3.2 向き自在版（Squeak 3.2 版 (ある意味、縦横対応版) (#5)へ追加）

って Array2D に変換した時点であとはなんでもありなんで、蛇足もいいとこなんですけどね…(^_^;)。--sumim

Calendar thisMonth asStringArray2D asHtmlTable asHtml "横 as →/↓"
Calendar thisMonth asStringArray2D transpose asHtmlTable asHtml "縦 as ↓/→"

Calendar thisMonth asStringArray2D reverseColumns asHtmlTable asHtml "←/↓"
Calendar thisMonth asStringArray2D transpose reverseColumns asHtmlTable asHtml "↓/←"
Calendar thisMonth asStringArray2D reverseRows asHtmlTable asHtml "→/↑"
Calendar thisMonth asStringArray2D transpose reverseRows asHtmlTable asHtml "↑/→"
Calendar thisMonth asStringArray2D reverseColumns reverseRows asHtmlTable asHtml "←/↑"
Calendar thisMonth asStringArray2D transpose reverseColumns reverseRows asHtmlTable asHtml "↑/←"
----
'From Squeak 3.2 of 11 July 2002 [latest update: #4917] on 7 September 2002 at 7:17:39 pm'!

!Array2D methodsFor: 'converting' stamp: 'sumim 9/7/2002 18:53'!
reverseColumns
| array2D |
array2D _ Array2D extent: self width @ self height.
1 to: self height do: [ :row |
array2D atRow: row put: (self atRow: row) reverse ].
^ array2D! !

!Array2D methodsFor: 'converting' stamp: 'sumim 9/7/2002 18:53'!
reverseRows
| array2D |
array2D _ Array2D extent: self width @ self height.
1 to: width do: [ :col |
array2D atCol: col put: (self atCol: col) reverse ].
^ array2D! !

[[id:1150]] 2002-09-07 19:28:27

GikoForth版（縦、GikoForth版 (プログラミング:企画もの:お題１)に対する差分）

: cal>html2 { yr mn ls | dn ds -- str }
wdList ::@ -> dn
|[ "<table><caption>" yr n>s "/" mn n>s "</caption>" $n ]| :[ ::+ ]: ::foldl1
|[ 7 0 DO
|[ :[ ::shift dup 0 > IF 2 [char] 0 n>$ ::@ ELSE drop "" THEN ]: ls ::each ]||
LOOP ]||
:[ |[ dn ::shift ]|| ::concat! ]: ::map!
:[ -> ds
"<tr>"
[; (_ _ _) ; |[ "<td>" ]| ; ds ; |[ "</td>" ]| ;] ::flatten1 :[ ::+ ]: ::foldl1
::+ "</tr>" ::+ $n ::+ ::+
]: ::each "</table>" ::+
;

2002 9 cal cal>html2 ::print

いつもどおり激しく読みにくいです。はい。
- どこがどうなって縦になるかサパーリ分かりませんでした。(^^; --SHIMADA

|[ 7 0 DO |[ :[ ::shift ]: ls ::each ]|| LOOP ]||

- 転置の部分だけを取り出すと↑
- Rubyのリンク先のlist 7と似たり寄ったりなんですが、shiftの結果をスタックにためてから新しい配列にまとめているところがForth的‥‥‥かな？
- 元の配列は破壊されるし、shiftを要素数分繰り返すので良くないアルゴリズムなんですがキータイプ数が少なかったので採用しますた。

GikoForthってどんな言語なんでしょう？
Forthにどういう拡張をしているのかが気になったのですが。
GikoForthWikiはどこを読んだらいいのか良くわからなかった(^^;--有野

GikoForthのまとまったドキュメントをまだつくってないんです。スミマセン。
http://gikoforth.s13.xrea.com/wiki/wiki.cgi?GikoForth%A4%C7%B3%C8%C4%A5%A4%B5%A4%EC%A4%BF%B5%A1%C7%BD%A4%CB%B4%D8%A4%B9%A4%EB%A5%E1%A5%E2
↑標準的なForthになくてGikoForthにあるものをまとめてみました。
……書きかけのメモ程度の内容ですけれども。

おぉ、凄い。なんかいろいろ面白そうですね。--有野

このページのGikoForth版ソースを直接実行できるv0.2.3をリリースしました。transposeメソッドもオマケしますた。-- ばしを

[[id:1113]] 2002-09-07 08:55:20

top recent

HashedWiki version 3 beta
SHIMADA Keiki