DouKaku?beta

Language detail: FORTRAN

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

Unsolved challenges

show all

codes

Feed

Used modules

next >>

２進数の記述 (Nested Flatten)

see: 2進、8進、16進定数 

1
2
3
4
5
6
program main
     implicit none
     integer:: boz
     boz = int(B'000000011')
     print *,boz
end program
倍数になる13進数 (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
program main
     implicit none
     integer:: ix; ix = 11
     do while((.not.isDividable(ix)))
         ix = ix + 1
     end do
     print *, ix
     contains
     function asBase13(x)
         integer, intent(in)::x
         integer::asBase13
         integer::hun,dec,one
         hun = x/100;
         dec = (x - hun*100)/10;
         one = x - 10*dec
         asBase13 = 13*13*hun + 13*dec + one
     end function
     function isDividable(x)
         integer,intent(in):: x
         logical:: isDividable
         integer::b13,div
         b13 = asBase13(x)
         div = b13/x
         isDividable = (b13 .eq. div * x)
     end function
end program
隣り合う二項の差 (Nested Flatten)

投稿するものを間違えました。

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
program Main
     integer,dimension(9):: xs
     xs = (/3,1,4,1,5,9,2,6,5/)
     print '(9i3)', xs
     print '(8i3)', diff(xs)
     contains
         function diff(xs)
             integer,intent(in):: xs(:)
             integer,dimension(size(xs)-1):: diff
             integer:: ix
             do ix = 1, size(diff)
                 diff(ix) = xs(ix+1) - xs(ix)
             end do
         end function
end program

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
Program Main
     implicit none
     Print *, Reverse_string("Hello World!")
     contains
         Function Reverse_string(str)
             character(*),intent(in):: str
             character(len(str)):: Reverse_string
             integer:: ix, rix, maxix; maxix = len(str)
             do ix = 1, maxix
                rix = maxix - ix + 1
                Reverse_string(rix:rix) = str(ix:ix) 
             end do
         End Function
End Program
文字列の反転 (Nested Flatten) 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
Program Main
     implicit none
     Print *, Reverse_string("Hello World!")
     contains
         Function Reverse_string(str)
             character(*),intent(in):: str
             character(len(str)):: Reverse_string
             integer:: ix, rix, maxix; maxix = len(str)
             do ix = 1, maxix
                rix = maxix - ix + 1
                Reverse_string(rix:rix) = str(ix:ix) 
             end do
         End Function
End Program
九九の表示 (Nested Flatten) 
 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
Module Universe
     implicit none
     Private
         integer::left,right
     Public :: Mult
     contains
         Subroutine Mult
             do left = 1,9
                 do right = 1,9
                     Print '(i1," * ",i1," = ",i2)',&
                             left, right, left*right
                 end do
             end do
         End Subroutine
End Module

Program Main
     use Universe
     implicit none
     call Mult
End Program
Hello, world! (Nested Flatten)

see: Fortran入門:モジュール 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
Module Universe
     implicit none
     Public :: HelloWorld
     contains
         Subroutine HelloWorld()
             Print *, "Hello World"
         End Subroutine HelloWorld
End Module

Program Main
     use Universe, Only: HelloWorld
     implicit none
     call HelloWorld
End Program Main
複素数 (Nested Flatten) 
深くは考えず、FORTRAN でやってみました☆

 (  7.0000000    ,  0.0000000    )
 (  3.0000000    , -15.000000    )
 (  1.0000000    ,  55.000000    )
 (  1.1333333    ,-0.40000001    )
   3.6055512
1
2
3
4
5
6
print *, ( 3, 1) + ( 4,-1)
print *, ( 5,-9) - ( 2, 6)
print *, ( 5, 3) * ( 5, 8)
print *, ( 9,-7) / ( 9,-3)
print *, abs(( 2, 3))
end
循環関数 (Nested Flatten)
問題の
    n = 1 のとき low + 1　を返す。
と
    n = 整数 * (high - low) + 1 のとき low を返す。
って矛盾してませんか？

d = high - low として，

k*d のとき high
k*d + 1 のとき low
k*d + 2 のとき low + 1
...
k*d + j のとき low + j - 1
...
このままいくと，
(k+1)*d - 1 のとき，つまり k*d + (d-1) のとき low + (d-1) - 1 = high - 2
そして，
(k+1)*d のき high - 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
integer function modular(n, low, high)
  implicit none

  integer, intent(in) :: n, low, high
  integer :: m

  if (low > high) then
     print *, "Error: low > high"
     stop
  end if

  m = mod(n, high - low)

  if (n < 0) then
     if (m == 0) then
        modular = low
     else
        modular = high + m + 1
     end if
  else if (n < high - low) then
     modular = low + m
  else
     if (m == 0) then
        modular = high
     else
        modular = low + m - 1
     end if
  end if

  return
end function modular


program doukaku180
  implicit none

  interface
     integer function modular(n, low, high)
       implicit none
       integer, intent(in) :: n, low, high
     end function modular
  end interface

  print *, modular(0,100,200)   ! -> 100
  print *, modular(50,100,200)  ! -> 150
  print *, modular(100,100,200) ! -> 200
  print *, modular(101,100,200) ! -> 100
  print *, modular(-1,100,200)  ! -> 200
  print *, modular(1,-5,200)    ! ->  -4
  print *, modular(-500,-5,-1)  ! ->  -5

  stop
end program doukaku180
リストを逆順に表示 (Nested Flatten) 
1
2
3
4
5
6
7
8
9
program doukaku27
  implicit none

  integer :: i, list(5) = (/ 1, 2, 3, 4, 5 /)

  print *, (list(i), i = 5, 1, -1)

  stop
end program doukaku27
ローテートシフト (Nested Flatten) 
1
2
3
4
5
6
program doukaku239

  print *, ishftc(9197, 1)

  stop
end program doukaku239
行列式の計算 (Nested Flatten)

こんどは Fortran

 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
recursive function det(A) result(d)
 implicit none

 real, dimension(:, :), intent(in) :: A
 real :: d

 integer :: i, j, jj, n
 real, dimension(:, :), allocatable :: B

 n = size(A, 1)

 if (n == 1) then
    d = A(1, 1)
 else
    allocate(B(n-1, n-1))
    d = 0
    do j = 1, n
       B(:, :j-1) = A(2:, :j-1)
       B(:, j:) = A(2:, j+1:)
       d = d + (-1)**(j+1) * A(1, j) * det(B)
    end do
    deallocate(B)
 end if

 return
end function det


program doukaku218
 implicit none

 interface
    recursive function det(A) result(d)
      implicit none
      real, intent(in) :: A(:, :)
      real :: d
    end function det
 end interface

 integer :: i
 real :: A(2, 2)

 A = reshape((/ (i, i = 1, 4) /), shape(A))

 print *, det(A)

 stop
end program doukaku218
Hello, world! (Nested Flatten) 
　あ，題意の Hello, world! になってませんね。全部大文字になっています。でも初期のFORTRANでは全部大文字になるのが当たり前だったんです。

　最近の処理系なら小文字でもコンパイルできますけど。
1
2
3
4
5
C234567
      WRITE(6,100)
      STOP
  100 FORMAT(1H ,13HHello, world!)
      END
アルファベットの繰り上がり (Nested Flatten) 
今回はFortran90でやってみました。
最下位桁の処理にとまどっています。
主プログラムに埋め込んである処理を
副プログラムにすると，もっと
Fortran90らしさを堪能できるかと
思います。
 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
PROGRAM ExcelNumbering

    IMPLICIT NONE
    INTEGER, PARAMETER :: MinNum =   1
    INTEGER, PARAMETER :: MaxNum = 100
    INTEGER, PARAMETER :: MaxLen =   7
    INTEGER, PARAMETER :: Radix  =  26
    INTEGER, PARAMETER :: Base   =  64
    INTEGER :: i, j, m, n
    CHARACTER(LEN = MaxLen) :: s = ''

    DO i = MinNum, MaxNum
        n = i
        j = MaxLen

        m = MOD(n, Radix)
        IF (m == 0) THEN
            n = n / Radix
            s(j:j) = CHAR(Base + Radix)
        ELSE
            n = n - m
            s(j:j) = CHAR(Base + m)
        END IF

        DO
            IF (n < Radix) EXIT
            n = n / Radix
            j = j - 1
            s(j:j) = CHAR(Base + n)
        END DO

        WRITE(*, '(A)') s
    END DO

END PROGRAM ExcelNumbering
Hello, world! (Nested Flatten) 
FORTRANと言ったらこうでしょう(^^;。
1
2
3
4
5
C234567
      WRITE(6,100)
      STOP
  100 FORMAT(1H ,13HHELLO, WORLD!)
      END
マルバツゲーム：賢いプレイヤー (Nested Flatten) 
　Wikipediaの完勝手順を参考に，以下の形で実装してみました。

1. 3マス揃う場合には揃える
2. 敵方にリーチが掛かっている場合には阻止する
3. ダブルリーチが掛けられる場合には掛ける
4. 敵方がダブルリーチを掛けられる場合には，以下の方法で阻止する
4-1. 敵方のダブルリーチを阻止できる形でリーチを掛けられる場合にはリーチを掛ける
4-2. 4-1以外の場合は，直接的にダブルリーチを阻止する
5. 中央が開いていれば中央に置く
6. 敵方の角の反対が空いていれば，その角に置く
7. 角が空いていれば角に置く
8. 1～7のいずれにも該当しない場合には，空いているマスに置く

　以下実行結果です。

1> c(tic_tac_toe).
{ok,tic_tac_toe}
2> tic_tac_toe:start().
first:0,second:8762,draw:1238
ok
3> tic_tac_toe:start({fun tic_tac_toe:clever_choice/2,fun tic_tac_toe:random_choice/2}).
first:9573,second:0,draw:427
ok
4> tic_tac_toe:start({fun tic_tac_toe:clever_choice/2,fun tic_tac_toe:clever_choice/2}).
first:0,second:0,draw:10000
ok

see: Wikipedia 

  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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
-module(tic_tac_toe).
-import(io).
-import(lists).
-import(random).
-export([start/0,start/1,random_choice/2,clever_choice/2]).

create_board() -> lists:map(fun(_) -> 0 end,lists:seq(1,9,1)).

enemy(P) -> P rem 2 + 1.

move(B,1,{C,_}) -> move(B,1,C);
move(B,2,{_,C}) -> move(B,2,C);
move(B,P,C) ->
    PS = C(B,P),
    lists:sublist(B,PS - 1) ++ [P|lists:sublist(B,PS + 1,length(B) - PS)].

check_pattern() ->
    lists:map(fun(X) -> lists:seq(X,X+6,3) end, lists:seq(1,3,1)) ++
    lists:map(fun(X) -> lists:seq(X,X+2,1) end, lists:seq(1,7,3)) ++
    [lists:seq(1,9,4),lists:seq(3,7,2)].

check(B,P) ->
    lists:any(
        fun(PT) ->
            lists:all(
                fun(ST) -> ST == P end,
                lists:map(fun(X) -> lists:nth(X,B) end, PT)
            )
        end,
        check_pattern()
    ).

process(B,P,C) ->
    BN = move(B,P,C),
    R = check(BN,P),
    D = lists:all(fun(ST) -> ST /= 0 end, BN),
    if
        R -> P;
        D -> 0;
        true -> process(BN, enemy(P), C)
    end.

process(C) -> process(create_board(),1,C).

random_choice(B,_) ->
    S = lists:map(fun({PS,_}) -> PS end, lists:filter(fun({_,X}) -> X == 0 end, lists:zip(lists:seq(1,length(B),1),B))),
    lists:nth(random:uniform(length(S)),S).

will_complete(B,P,PL) ->
    lists:filter(
        fun(SL) ->
            (length(lists:filter(fun({_,S}) -> S == P end, SL)) == 2) and
            (length(lists:filter(fun({_,S}) -> S == 0 end, SL)) == 1)
        end,
        lists:map(
            fun(PP) -> lists:map(fun(PS) -> {PS,lists:nth(PS,B)} end, PP) end,
            PL
        )
    ).

proposed_complete(B,P,PL) ->
    lists:map(
        fun(SL) ->
            {PS,_} = lists:nth(1, lists:filter(fun({_,S}) -> S == 0 end, SL)),
            PS
        end,
        will_complete(B,P,PL)
    ).

check_fork(B,P) -> length(will_complete(B,P,check_pattern())) >= 2.

lookahead(F,B,P) ->
    lists:filter(
        F,
        lists:map(
            fun({PT,_}) ->{PT,lists:sublist(B,PT - 1)++[P|lists:sublist(B,PT + 1,length(B) - PT)]} end,
            lists:filter(fun({_,S}) -> S == 0 end, lists:zip(lists:seq(1,9,1),B))
        )
    ).

proposed_fork(B,P,_) ->
    lists:map(
        fun({PS,_}) -> PS end,
        lookahead(fun({_,BP}) -> check_fork(BP,P) end,B,P)
    ).

proposed_block_fork(B,P,PL) ->
    FL = proposed_fork(B,enemy(P),PL),
    F = length(FL),
    if
        F == 0 -> [];
        true ->
            lists:map(
                fun({PS,_}) -> PS end,
                lookahead(
                    fun({_,BP}) ->
                        (length(lists:subtract(proposed_complete(BP,P,check_pattern()),FL)) > 0) or
                        (length(proposed_fork(BP,enemy(P),[])) == 0)
                    end,
                    B,
                    P
                )
            )
    end.

proposed_opposite(B,P,PL) ->
    lists:filter(
        fun(PS) -> lists:nth(PS,B) == 0 end,
        lists:map(
            fun({EP,_}) ->
                {_,OP} =
                    lists:nth(1,
                        lists:filter(
                            fun({CP,_}) -> CP == EP end,
                            lists:zip(PL,lists:map(fun(X) -> 10 -X end, PL))
                        )
                    ),
                OP
            end,
            lists:filter(
                fun({_,S}) -> S == enemy(P) end,
                lists:zip(PL,lists:map(fun(PT) -> lists:nth(PT,B) end, PL))
            )
        )
    ).

proposed_space(B,_,PL) -> lists:filter(fun(PS) -> lists:nth(PS,B) == 0 end, PL).

clever_choice(B,P) ->
    lists:nth(
        1,
        lists:append(
            lists:map(
                fun({F,PP,PL}) -> F(B,PP,PL) end,
                [    {fun proposed_complete/3,P,check_pattern()},
                    {fun proposed_complete/3,enemy(P),check_pattern()},
                    {fun proposed_fork/3,P,[]},
                    {fun proposed_block_fork/3,P,[]},
                    {fun proposed_space/3,0,[5]},
                    {fun proposed_opposite/3,P,[1,3,7,9]},
                    {fun proposed_space/3,0,[1,3,7,9]},
                    {fun proposed_space/3,0,[2,4,6,8]}
                ]
            )
        )
    ).

start(C) ->
    R = lists:map(fun(_) -> process(C) end,lists:seq(1,10000,1)),
    io:format("first:~w,second:~w,draw:~w~n",lists:map(fun(P) -> length(lists:filter(fun(X) -> X == P end, R)) end,[1,2,0])).

start() -> start({fun random_choice/2,fun clever_choice/2}).
ワーカスレッドを安全に終了させるまで待機 (Nested Flatten) 
FORTRAN / OpenMP で。
15行で明示的に 8 threads 生成
18行で空きスレッドに仕事を割り当て
22行で NOWAIT 指定によりスレッド間同期を取らずに先へ
24行で全てのスレッドの終了待ち、
ってところです。

スレッドプールの管理は OpenMP に任せきりですが、通常の実装ではスレッドプールは残される、んではないかと。
# OpenMP の仕様を読みきれていない....



 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
      subroutine random_wait(i)
      integer omp_get_thread_num, omp_get_num_threads
      j=mod(irand(),10)
      write(*,'(AI2AI2AI2AI2)') 'begin ',i,' - ',j,' sec, thread ',
     c     omp_get_thread_num(), '/', omp_get_num_threads()
      call sleep(j)
      write(*,'(AI2AI2AI2AI2)') 'end   ',i,' - ',j,' sec, thread ',
     c     omp_get_thread_num(), '/', omp_get_num_threads()
      end

      program thread_test
      integer omp_get_thread_num, omp_get_num_threads
      write(*,*) 'Single Thread'
      call sleep(4)
!$OMP PARALLEL NUM_THREADS(8)                                                   
      write(*,'(AI2AI2)') 'Multi Thread ',
     c     omp_get_thread_num(),'/',omp_get_num_threads()
!$OMP DO SCHEDULE(DYNAMIC)                                                      
      do i=1,20
         call random_wait(i)
      end do
!$OMP END DO NOWAIT                                                             
      write(*,'(AI2)') 'finish', omp_get_thread_num()
!$OMP BARRIER                                                                   
!$OMP MASTER                                                                    
      write(*,*) 'Finish'
!$OMP END MASTER                                                                
!$OMP END PARALLEL                                                              
      end
ピラミッドを作る (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
program main
      call pyramid(1)
      write(*,*)
      call pyramid(2)
      write(*,*)
      call pyramid(3)
      write(*,*)
      call pyramid(4)
      write(*,*)
      call pyramid(5)
      end

      subroutine pyramid(height)
      integer width, height, w
      w = (height - 1)
      width = w * 2 + 1
      do i = 1, height
         call draw(' ', w - i + 1)
         call draw('*', i - 1)
         write(*, '(a$)') '*'
         call draw('*', i - 1)
         call draw(' ', w - i + 1)
         write(*,*)
      end do
      end

      subroutine draw(c, count)
      character c
      integer count
      do i=1, count
         write(*, '(a$)') c
      end do
      end
与えられた数字のケタ数 (Nested Flatten) 
なんかFortranがようやく分かってきた。
1
2
3
4
5
6
7
8
    INTEGER i
    INTEGER keta

    read(*, *) i
    keta = INT(ALOG10(FLOAT(i))) + 1
    write(*, *) '桁数:', keta, ' 最大桁:', 10 ** (keta - 1)

    end
九九の表示 (Nested Flatten) 
初めてのFortranです><
なんか1行目のインデントが効いていないけどタブが存在してます。
1
2
3
4
5
6
7
8
9
do i = 1, 9
        do j = 1, 9
            write(*, 100) i, j, i * j
        end do
    end do

100    format(i1, ' + ', i1, ' = ', i2)

    end
next >>

Index

Feed

Other

Link

Pathtraq

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