DouKaku?beta

Language detail: PostScript

Coverage: 36.15%
number of '+' ratings
 contribution for coverage

Unsolved challenges

show all

codes

Feed

Used modules

next >>

LL Golf Hole 2 - 文字列に含まれる単語の最初の文字を大文字にする (Nested Flatten)

PostScript でもう少し真面目に。上のも含めて標準出力に出力します。

1
2
3
4
5
6
7
8
9
[(LL future)(LL day and night)(echo $home)(hello,  i am a cat.)]/l{( )search exch dup(a)ge 1 index({)lt and{0 2 copy get -33 and put[}if pop{pop l}if}def{dup l =}forall
% 出力
LL Future
LL Day And Night
Echo $home
Hello,  I Am A Cat.

% バイナリーエンコードする場合はこちらの方が短い
[(LL future)(LL day and night)(echo $home)(hello,  i am a cat.)]{dup{( )search exch dup(a)ge 1 index({)lt and{0 2 copy get -33 and put[}if pop not{exit}if pop}loop =}forall

PostScript 不真面目版。スペースが2個続くとエラーで止まります。

余談ですが、s/与力/余力/ ですね。

1
2
3
4
5
6
7
[(LL future)(LL day and night)]/l{( )search exch 0 2 copy get -33 and put{pop l}if}def{dup l =}forall
% 出力
LL Future
LL Day And Night

% バイナリーエンコードする場合はこちらをエンコードしたものの方が短い
[(LL future)(LL day and night)]{dup{( )search exch 0 2 copy get -33 and put not{exit}if pop}loop =}forall
環境変数の取得 (Nested Flatten)

親OS上の環境変数の取得ということで、GhostScript 依存の getenv operator を使用しました。 PostScript の本来の環境変数（デバイス解像度等）は普通に currentdict 中に入っているわけで、普通に変数名だけで参照できるわけですが、マクロ等も一緒に入っているのでいわゆる変数一覧、というのは 膨大になると思います。後半のようにうっかり forall を使ってアクセスするとスタックがあふれたりとか....

1
2
3
4
5
6
7
%!PS

(PATH) getenv { = } if

% ========= Cut Here ===========
%!PS
currentdict { === } forall
コード圧縮 (Nested Flatten)

Postscript では、通常、コードは実行可能な圧縮配列の形で current dict に記録されるので、それを書きだす、という方向 でいいのでしょうかね.... あまり潰しが利きませんが...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
%!PS

% テスト用コード
/TestProc { % Hogehoge Fugafuga
    1 3 roll 10 add % areare
    (abc%Hoge) == == % zzz
} def

% ========  出力
currentdict /TestProc get ==

% ======== 以下出力結果
% {1 3 roll 10 add (abc%Hoge) == ==}
比較しないソートの作成 (Nested Flatten)

PostScriptで、radix sort 基数2 です。 特にかわったことはやっていない筈です。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
%!PS

/AddToVector { % val [Vector]  AddToVector  [NewVector]
    [ 3 1 roll
    {
        1 index add exch
    } forall
    pop
    ]
} bind def

/RadixSortCore { % [Vector]  max  RadixSortCore  [NewVector]
    5 dict begin 
    /Max exch def
    /Vect exch def
    /Radix 1 def
    {
        /Vect
        [
            Vect {
                dup Radix and 0 ne {
                    pop
                } if
            } forall
            Vect {
                dup Radix and 0 eq {
                    pop
                } if
            } forall
        ] def
        Radix Max gt { exit } if
        /Radix Radix dup add def
    } loop
    Vect
    end
} bind def

/RadixSort { % min max [Vector] RadixSort [NewVector]
    2 index neg exch AddToVector exch 2 index sub
    RadixSortCore
    AddToVector
} bind def

% ============ Test Code ==============
-1024 2048 [ -510 10 7 12 45 120 -1024 -511 -512 249 1238 1274 ] RadixSort ==
設定ファイルから値を取得 (Nested Flatten) 
普通 PostScript ではプリンタ依存性が大きくなるので外部ファイルの読み込みをユーザープログラムでやることはないと思います。
ここでは GhostScript で試しています。

ShowPrice.ini
--- Cut Here ---
/ITEM_NAME (リンゴ)
/ITEM_COST 200
--- Cut Here ---

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
%!PS

/ReadPrice { % (filename.ini)  ReadPrice  -dict-
    << exch runlibfile >>
} bind def

% --- Test Code ---

(ShowPrice.ini) ReadPrice

dup (ITEM_NAME) get
(「) print print (」は) print

dup (ITEM_COST) get
1.05 mul 0.5 add cvi 10 string cvs print (円(税込み)) =

pop
コメントの削除 (Nested Flatten)

修正版... 文字列中に%を書けたとは...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
%!PS

/Decomment { % (filename) Decomment -
    true exch
    0 exch
    (r) file
    {
        % outputflag file
        dup read
        not { exit } if
        dup 40 eq {
            3 -1 roll 1 add 3 1 roll
        } if
        dup 41 eq {
            3 -1 roll 1 sub 3 1 roll
        } if
        dup 37 eq {
            2 index 0 eq {
                4 -1 roll pop false 4 1 roll
            } if
        } if
        dup dup 10 eq exch 13 eq or {
            4 -2 roll pop pop true 0 4 2 roll
        } if
        3 index {
            ( ) dup 0 4 -1 roll put
            print
        } {
            pop
        } ifelse 
    } loop
    pop pop pop
} bind def

%---- Test Code ----
(====%===) pop % ==
(decomment.ps) Decomment
n人中m人が当選するくじ (Nested Flatten)

n 人中1人を抜き出し、更に残りから 1人を抜きだし、を繰り返しです。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
%!PS

/Kuji { % n m Kuji [numbers]
    [ 3 1 roll
    [
        1 1 5 -1 roll { } for
        dup 2 add -1 roll
        {
            counttomark dup rand exch mod roll
            counttomark 1 add 1 roll
        } repeat
    ] pop
    ]
} bind def

% ----- Test Code ---------
100 20 Kuji ==
コメントの削除 (Nested Flatten)

言語仕様的には PostScript では%以降がコメントになります。 ただしプリンタや処理系によってはコメント中の情報を用いて処理をする場合があります...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
%!PS

/Decomment { % (filename) Decomment -
    true exch
    (r) file
    {
        % outputflag file
        dup read
        not { exit } if
        dup 37 eq {
            3 -1 roll pop false 3 1 roll
        } if
        dup dup 10 eq exch 13 eq or {
            3 -1 roll pop true 3 1 roll
        } if
        2 index {
            ( ) dup 0 4 -1 roll put
            print
        } {
            pop
        } ifelse
    } loop
    pop pop
} bind def

%---- Test Code ----
(decomment.ps) Decomment
格子点の列挙 (Nested Flatten)

力技で.. Bubble Sort したら遅かったので無理矢理 Quick Sort を実装。まだ荒削りですが。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
%!PS

/CompareVal { % [R X Y Theta] [R2 X2 Y2 Theta2 ] CompareXY  integer
    2 copy 0 get exch 0 get sub
    dup 0 eq
    {
        pop
        3 get exch 3 get sub
    } {
        exch pop exch pop
    } ifelse
    neg
} bind def

/QSort { %  [Array] /CompareFunction  QSort  [Array']
    cvx
    1 index 0 get
    0 3 index length 1 sub
    % [Array] Comp pivot l r
    {
        2 copy ge { exit } if 
        {
            2 copy ge { exit } if
            4 index 1 index get 3 index 5 index
            exec 0 lt { exit } if
            1 sub
        } loop
        2 copy ne {
            4 index 1 index get
            5 index exch 3 index exch put
            exch 1 add exch
        } if
        {
            2 copy ge { exit } if
            4 index 2 index get 3 index 5 index exec 0 gt { exit } if
            exch 1 add exch
        } loop
        2 copy ne {
            4 index 2 index get
            5 index exch 2 index exch put
            1 sub
        } if
    } loop
    4 index 2 index 4 index put 
    1 index 1 gt {
        4 index 0 3 index getinterval
        4 index QSort pop
    } if
    % [Array] Comp pivot l r
    4 index length 1 index 2 add gt {
        4 index dup length 3 index sub 1 sub  3 index 1 add exch getinterval
        4 index
        QSort pop
    } if
    pop pop pop pop
} bind def


/GenLattice { % N  GenLattice  [ [r^2 x1 y1 angle] ... ]
    [ exch
    2 div sqrt 1 add cvi
    dup neg exch 1 exch
    % [ -X0 1 X0 
    3 copy {
        % [ -X0 1 X0 Y
        4 copy pop {
            % [ -X0 1 X0 Y X
            2 copy [ 3 1 roll
            % [ -X0 1 X0 Y X  [ Y X
            2 copy dup mul exch dup mul add sqrt
            3 1 roll
            2 index 0 eq { 0 } { 2 copy atan } ifelse
            ]
            % [ -X0 1 X0 Y X  [ r^2 Y X theta ]
            6 1 roll pop
            % [ [] -X0 1 X0 Y 
        } for
        pop
    } for
    pop pop pop ]
} bind def

/DisplayLatticePoints { % N  DisplayLatticePoints  -
    dup GenLattice /CompareVal QSort
    0 1 4 -1 roll
    {
        1 index exch get aload pop pop
        10 string cvs print (, ) print =
        pop
    } for
    pop
} bind def

1000 DisplayLatticePoints
ミリ秒まで含んだ時刻文字列 (Nested Flatten)

PostScript では realtime オペレータで現在時刻を取り出せるのですが、なんと原点(0)がいつを指すかは未定義です。 そのため、別途パラメータで補ってやる必要があります。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
%!PS

/ZeroNum { % integer (string) ZeroNum (string')
    dup dup length dup string
    5 -1 roll exch cvs dup length
    3 -1 roll sub neg exch putinterval
} bind def

/GetClock { %
    % Input
    %   Offset1(YYYYMMDD in int)
    %   Offset2(offset for realtime clock to 00:00:00.000 in millisec)
    % Output
    %    (String)
    (YYYYMMDD000000.000) dup 0 8 getinterval 4 -1 roll exch ZeroNum pop
    exch
    realtime 86400000 mod add 86400000 add 86400000 mod
    dup 1000 mod  2 index 15 3 getinterval ZeroNum pop 1000 idiv 
    dup 60 mod 2 index 12 2 getinterval ZeroNum pop 60 idiv
    dup 60 mod 2 index 10 2 getinterval ZeroNum pop 60 idiv
    1 index 8 2 getinterval ZeroNum pop
} bind def

% ========= Test Code ============
20080616 32940000 GetClock ==
コード中の文字の頻度分析 (Nested Flatten) 
PostScript で... 
自分自身を食わせると 
32 ( ) 293
10 [*] 61
101 (e) 51
114 (r) 48
116 (t) 47
111 (o) 42
112 (p) 34
くらいで、roll, copy, exch あたりのスタック操作命令が結構稼いでいるかと思います。
(t はコメントと変数名が...)
一般的な PostScript File の傾向は.... あまりに傾向が散らばりすぎてよくわかりません。
例えば PhotoShop で作成した巨大bitmap の eps file などでは、
コードよりも圧倒的に多量の embed されたデータが傾向を
決めることになってしまいます。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
%!PS

/CompareVal { % [I1 V1] [I2 V2] CompareXY [I1 V1] [I2 V2] V2-V1
    2 copy 1 get exch 1 get sub 
} bind def

/Sort { % [[x y] [x1 y1] Array Data ] {CompareFunction}  Sort [ArrayData]
    cvx [ 3 -1 roll
    aload length
    % func -mark[- [] [] [] [] [] len
    -1 2 { % func -mark[- [] [] [] [] [] len2
        -1 2 {
            3 1 roll
            counttomark 1 add index exec  %% Compare
            0 lt { exch } if
            3 -1 roll
            1 roll
        } for
        counttomark 1 roll
    } for
    counttomark 1 roll
    ] exch pop
} bind def


/CountLetters {
    [ 0 1 255 { [ exch 0 ] } for ]
    {
        dup 2 index read
        {
            % array code
            get dup 1 get 1 add 1 exch put
        } {
            exit
        } ifelse
    } loop
    /CompareVal Sort
    exch pop exch pop
} bind def


/PrintResult {
    0 1 255 {
        2 copy get
        % [Array] i [I V]
        dup 0 get dup dup dup 3 string cvs print ( ) print
        32 ge exch 127 lt and {
            % [Array] i [I V] I 
            (( ) ) dup 1 4 -1 roll put print
        } {
            ([*] ) print
            pop
        } ifelse
        1 get =
        pop 
    } for
    pop
} bind def

%(countletter2.ps) (r) file CountLetters
(%stdin) (r) file CountLetters
PrintResult
文字列のセンタリング (Nested Flatten)

PostScript で。 PostScript で文字数単位でやる実用性はほとんど無いでしょうね。 通常はフォント指定して文字列幅を計算、幅にあわせて切り捨てるなり圧縮するなり、でしょうから。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
%!PS

/FillSpace { % (String) FillSpace (String')
    dup length 1 sub 0 1 3 -1 roll {
        1 index exch 32 put
    } for
} bind def

/Centering { % (String) length Centering (NewString)
    dup string FillSpace dup
    3 index length 4 -1 roll
    2 copy le {
        sub neg 2 idiv 4 -1 roll putinterval
    } {
        2 copy sub 2 idiv 
        exch 6 -1 roll 3 1 roll getinterval
        exch pop 0 exch putinterval
    } ifelse
} bind def

% -------------------- Test Code ------------------
(ABC) 10 Centering ==
(ABCDEF) 10 Centering ==
(ABCDEF) 3 Centering ==
(ABCDEF) 6 Centering ==
循環関数 (Nested Flatten)

PostScript です。 50% のカバレッジを目指しているのですが、なかなか...

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
!PS

/modular { % n low high  modular  result
    1 index sub 1 add 3 -1 roll 1 index mod
    dup 0 lt { add } { exch pop } ifelse add
} bind def

% --- Test Code ---
0 100 200 modular =
50 100 200 modular =
100 100 200 modular =
101 100 200 modular =
-1 100 200 modular =
1 -5 200 modular =
-500 -5 -1 modular =
出力の一時停止と再開 (Nested Flatten)

無謀にも PostScript で。 GhostScript 7.07 のファイル関連のオペレーターのbug だか仕様だかに泣かされました...

どうにもならなかったので ghostscript 2本並列実行で文字入力と表示を役割分担しています。 プロセス間通信は名前付きファイルで... 激しくファイルの open/close をしますので実用的ではありません。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
%% Terminal 1
%   stty raw < /dev/tty
%   gs -sDEVICE=nullpage echoback.ps 

%% Terminal 2
%   gs -sDEVICE=nullpage pause.ps 

%------------------ echoback.ps ----- Cut Here ---------
%!PS

/Stdin (%stdin) (r) file def
(/tmp/test) (w) file closefile

% p: 112, q: 113
{
    Stdin read
    {
        (/tmp/test) (w) file dup 2 index write closefile
        113 eq { exit } if
    } {exit} ifelse
} loop
quit



%--------------------  pause.ps ------  Cut Here  ---------
%!PS

/Sleep { % OutputFlag Timer  Sleep   OutputFlag'
    realtime
    {
        realtime 1 index sub
        2 index ge {exit} if
        (/tmp/test) (r) file dup read 
        {
            exch closefile (/tmp/test) (w) file exch
            dup 113 eq { quit } if
            112 eq { 4 -1 roll not 4 1 roll } if
        } if
        closefile
    } loop
    pop
    pop
} def


true 
{
    1000 Sleep
    dup {(a) print flush} if
} loop
METHINKS IT IS A WEASEL (Nested Flatten)

PostScript で素直に実装してみたのですが、 なかなか収束しないので皆さんと同様、 5個のバリエーションを生成、元の文字列も 残す方向です。

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
%!PS
% ---- Parameters ----------------------------------
/String (ABCDEFGHIJKLMNOPQRSTUVWXYZ) def
/Target (METHINKSITISAWEASEL) def
/NumStrings 300 def
/NumMutations 5 def
/Keep true def
% ---------------------------------------------------


/TargetLength Target length def
/StringLength String length def


/RandomLetter {
    String rand StringLength mod get
} bind def

/Diff { % (TargetString) (string) Diff  (TargetString) (string)  integer
    0
    0 1 TargetLength 1 sub {
    % (str) (tar) sum count
    dup 4 index exch get
    % (str) (tar) sum count  let
    exch 3 index exch get
    % (str) (tar) sum count  let let2
%    sub abs add   
%    sub dup mul add   
    sub 0 ne { 1 add } if
    } for
} bind def


/GenStrings { % NumStrings TargetLength GenStrings [(String1) ... (String N)]
    exch
    [ 3 1 roll
    % [ Len Num
    {
        % [ Len
        dup dup string exch
        % [ Len (Str) Len
        0 1 3 -1 roll 1 sub {
        % [ Len (Str) count
        1 index exch RandomLetter put
        } for
        exch
    } repeat
    pop
    ]
} bind def

/CalcDistance { % (TargetString) (String) CalcDistance (Target) [dist (str)]
    Diff exch 2 array astore
} bind def

/Sort { % [[x y] [x1 y1] Array Data ] Sort [ArrayData]
    [ exch
    aload length
    % func -mark- [] [] [] [] [] len
    -1 2 { % func -mark- [] [] [] [] [] len2
    -1 2 {
        3 1 roll
        2 copy 0 get exch 0 get sub
        0 gt { exch } if
        3 -1 roll
        1 roll
    } for
    counttomark 1 roll
    } for
    counttomark 1 roll
    ] 
} bind def

/Mutation { % (String)  Mutation  (String')
    dup dup length rand exch mod RandomLetter put
} bind def



NumStrings TargetLength GenStrings
[ exch Target exch {
    CalcDistance exch
} forall pop ]
Sort

{
[ exch {
    1 get
    % (str)
    NumMutations {
    % (str) (str') (str') 0
    dup length string dup 0 3 index putinterval
    Mutation
    } repeat
    Keep not { NumMutations 1 add -1 roll pop } if
} forall ]
[ exch Target exch {
    CalcDistance exch
} forall pop ]
Sort
0 NumStrings getinterval
dup 0 get dup == flush
0 get 0 eq {quit} if
} loop
マルバツゲーム (Nested Flatten) 
あんまり綺麗なコードじゃないですが、 PostScript で。

O win : 5892
draw  : 1247
X win : 2861

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
%!PS

/ShowMap { % [Map Vector]  ShowMap  -
    aload length sqrt cvi
    dup { % v0 v1 ... vn N
        dup { % v0 v1 ... vn N
            exch dup
            0 gt { pop (O) } { 0 lt { (X) } { ( ) } ifelse } ifelse
            print
        } repeat
        () =
    } repeat
    pop
    () =
} bind def

/DotProduct { % [Vector1] [Vector2]  DotProduct scaler
    [ 3 1 roll
    dup length 1 sub 0 1 3 -1 roll {
        3 copy get 3 1 roll exch get mul 3 1 roll
    } for
    pop pop
    ]

    0 exch
    { add } forall
} bind def

/CheckerVector [
        [ 1 1 1 0 0 0 0 0 0 ]
        [ 0 0 0 1 1 1 0 0 0 ]
        [ 0 0 0 0 0 0 1 1 1 ]
        [ 1 0 0 1 0 0 1 0 0 ]
        [ 0 1 0 0 1 0 0 1 0 ]
        [ 0 0 1 0 0 1 0 0 1 ]
        [ 1 0 0 0 1 0 0 0 1 ]
        [ 0 0 1 0 1 0 1 0 0 ]
    ] def

/KachiMake { % [Map Vector]  KachiMake   integer
    dup length sqrt cvi 0 exch
    CheckerVector
    {
        % [Map] 0 N [V]
        3 index DotProduct
        dup
        % [Map] 0 N V V
        2 index eq {
            pop pop 1 exch exit
        } {
            % [Map] 0 N V
            1 index neg eq {
                pop -1 exch exit
            } if
        } ifelse
    } forall
    pop exch pop
} bind def


/Okeru { % [Map] Okeru [Okeru]
    [ exch dup length 1 sub
    0 1  3 -1 roll
    {
        2 copy get 0 eq {
            exch
        } {
            pop
        } ifelse
    } for
    pop
    ]
} bind def

/RandomPlayer { % [Map] player RandomPlayer [Map'] bool
    % player: -1 or 1
    exch dup dup 4 2 roll Okeru
    dup length dup
    0 gt {
        rand 1024 idiv exch mod
        get
        exch put true
    } {
        pop pop pop pop false
    } ifelse
} bind def

/Marubatsu { % [Map] int /Proc1 /Proc2 Marubatsu  int
    % Result: 0 : draw, 1: O win, -1: X win

    % Initial Table
    4 copy 2 index 1 lt {
        exch
    } if
    pop
    cvx exec
    {
        KachiMake dup 0 eq
        {
            pop
            3 -1 roll neg 3 1 roll
            Marubatsu
        } if
    } {
        pop 0
    } ifelse
} bind def

% Randmize
realtime srand

% Counter
[0 0 0]

10000 {
    [0 0 0 0 0 0 0 0 0] 1 /RandomPlayer /RandomPlayer Marubatsu
    5 1 roll pop pop pop
%    ShowMap
    pop
    1 add 2 copy 2 copy get 1 add put pop
} repeat

aload pop
(O win : ) print =
(draw  : ) print =
(X win : ) print =
変形Fizz-Buzz問題 (Nested Flatten) 
PostScript で。
文字列処理はやっかいなので、素直に条件を満たしたら上書きで。

1
2
3
4
5
6
7
8
9
%!PS
1 1 20 {
    (hoge)
    1 index 3 mod 0 eq { pop (Fizz) } if
    1 index 5 mod 0 eq { pop (Buzz) } if
    1 index 15 mod 0 eq { pop (FizzBuzz) } if
    exch 10 string cvs print (:) print
    =
} for
実行時間の測定 (Nested Flatten) 
#6128 をベースに少しいじりました。
実際に使用するならば #6128 のほうが融通が効く気がします。

see: メソッドのフック #6128 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
%!PS
/TimerStart { % (Label) TimerStart -  
    (Enter: ) print dup =
    currentdict /ProfilingTimer known not {
        /ProfilingTimer  10 dict def
    } if
    ProfilingTimer exch 2 copy known {
        get
    } {
        [0 0] dup 4 1 roll put
    } ifelse
    1 usertime 1000 div put 
} bind def

/TimerStop { % (Label) TimerStop -  
    (Leave: ) print dup print ( : ) print
    
    currentdict /ProfilingTimer known {
        ProfilingTimer exch 2 copy known
        {
            get
            aload 3 1 roll
            usertime 1000 div sub neg
            dup 10 string cvs print ( sec  Total =) print
            add
            dup 10 string cvs print ( sec) =
            0 exch put
        } {
            pop pop
        } ifelse
    } {
        pop
    } ifelse
} bind def

/profile { % ...function arguments...  /Function  profile  -
    currentdict /ProfileFunction-temp known not {
        /ProfileFunction-temp [] def
    } if
    dup 
    ProfileFunction-temp aload length 1 add dup 1 add -1 roll exch
    % /Func [F1 (Func)]
    array astore /ProfileFunction-temp exch def
    dup 100 string cvs TimerStart 
    cvx exec
    ProfileFunction-temp aload length 1 sub exch
    100 string cvs TimerStop
    array astore /ProfileFunction-temp exch def
} bind def
% ----------------- Test Code ----------------

/TestLoop2 { % Count  TestLoop2 -
    10000 mul {
        1000 {
        } repeat
    } repeat
} def 

/TestLoop { % - TestLoop -
    0 1 5 {
        /TestLoop2 profile
    } for
} def

/TestLoop profile
メソッドのフック (Nested Flatten) 
PostScript です。
なんか、もっと簡単に書く方法がありそうな。
TestFunction, EnterFunction, LeaveFunction が定義されているとして、
/TestFunction (Label) /EnterFunction /LeaveFunction AddHook
のようにして使用します。(ネスト可)
外すときには
/TestFunction RemoveHook 
で、TestFunction に関して最後に指定したものから1段階外れます。

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
%!PS

/HookExec { % {Function} (Memo) {EnterFunction} {LeaveFunction}  HookExec  -
    2 index 3 -1 roll cvx exec
    currentdict /HookFunctions-temp known not
    {
        /HookFunctions-temp [] def
    } if
    HookFunctions-temp aload length dup
    3 add -2 roll
    3 -1 roll 2 add array astore
    /HookFunctions-temp exch def

    cvx exec
    
    HookFunctions-temp aload length 2 sub 3 1 roll cvx
    exec

    array astore
    /HookFunctions-temp exch def
} bind def


/AddHook { % {Function} (Memo) {EnterFunction} {LeaveFunction}  AddHook  -
    currentdict 4 index known
    {
        currentdict 4 index get
        4 1 roll
        currentdict exch 2 copy known {
            get cvx
        } {
            cvx exch pop
        } ifelse
        exch
        currentdict exch 2 copy known {
            get cvx
        } {
            cvx exch pop
        } ifelse
        exch

        /HookExec cvx
        % /TestLoop2 {Func} (Memo) {Enter} {Leave}
        5 array astore
        % /TestLoop2 [  ]
        cvx currentdict 3 1 roll put
    } {
        (Can't hook ) print pop pop print ( / ) print =
    } ifelse
} bind def


/RemoveHook { % /Function Name RemoveHook
    dup currentdict exch known
    {
        dup currentdict exch get
        dup length 5 eq {
            dup 4 get /HookExec eq {
                0 get 
                def
            } {
                (Remove Hook: Invalid data ) print pop =
            } ifelse
        } {
            (Remove Hook : Ignored ) print pop =
        } ifelse
    } {
        (Remove Hook : Unknown Operator) print =
    } ifelse
} bind def

% ----------------- Test Code ----------------
/EnterHook { % (Label) EnterHook -  
    (Enter: ) print dup =
    currentdict /ProfilingTimer known not {
        /ProfilingTimer  10 dict def
    } if
    ProfilingTimer exch 2 copy known {
        get
    } {
        [0 0] dup 4 1 roll put
    } ifelse
    1 usertime 1000 div put 
} bind def

/LeaveHook { % (Label) LeaveHook -  
    (Leave: ) print dup print ( : ) print
    
    currentdict /ProfilingTimer known {
        ProfilingTimer exch 2 copy known
        {
            get
            aload 3 1 roll
            usertime 1000 div sub neg
            dup 10 string cvs print ( sec  Total =) print
            add
            dup 10 string cvs print ( sec) =
            0 exch put
        } {
            pop pop
        } ifelse
    } {
        pop
    } ifelse
} bind def

/TestLoop2 { % Count  TestLoop2 -
    10000 mul {
        1000 {
        } repeat
    } repeat
} def 

/TestLoop { % - TestLoop -
    0 1 5 {
        TestLoop2
    } for
} def

/TestLoop2 (Loop2) /EnterHook /LeaveHook AddHook 
% 2nd level hook
/TestLoop2 (Loop2) {(Enter ) print =} {(Leave ) print =} AddHook

/TestLoop (Loop) /EnterHook /LeaveHook AddHook 

TestLoop

%Remove top level hook

/TestLoop2 RemoveHook

TestLoop
next >>

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]