sort -- テキストファイルの整列 ― 2015年07月12日 11:37
テキストファイルのソートに取り組みます。方針としては、STDINからEOFまで行単位ですべて読み込み、ソートし、 結果をSTDOUTに書き出します。
その前に、sortを作成中にgetlin()のbugを見つけました。返す値が、NEWLINE一文字分少なく返していました。修正版は下記の通り。
c getlin.for -- get line from infile
integer function getlin(line,u)
integer*1 line(81+1) ! MAXLINE(81)+1
integer u
integer*1 c,fgetc
integer col
if (fgetc(u,c) .ne. -1) then ! EOF(-1)
col = 0
while (c .ne. 10) do ! NEWLINE(10)
col = col + 1
line(col) = c
c = fgetc(u,c)
end while
line(col + 1) = 10 ! NEWLINE(10)
line(col + 2) = -2 ! EOS(-2)
getlin = col + 1
else
getlin = -1 ! EOF(-1)
end if
return
end
さて、sortのメインルーチンは下記のようになります。
RATFOR版は以下の通り。
# sort.r4 -- sort text line in memory
character linbuf(MAXTEXT)
integer gtext
integer linptr(MAXPTR),nlines
call initfile()
if (gtext(linptr,nlines,linbuf,STDIN) == EOF) {
call shell(linptr,nlines,linbuf)
call ptext(linptr,nlines,linbuf,STDOUT)
}
else
call error('too big to sort.')
stop
end
WATCOM fortran77版は、以下の通り。
c sort.for -- sort text line in memory
integer*1 linbuf(500000) ! MAXTEXT(500000)
integer gtext
integer linptr(1000),nlines ! MAXPTR(1000)
call initfile()
if (gtext(linptr,nlines,linbuf,5) .eq. -1) then ! STDIN(5) EOF(-1)
call shell(linptr,nlines,linbuf)
call ptext(linptr,nlines,linbuf,6) ! STDOUT(6)
else
call error('too big to sort.')
end if
stop
end
gtext()は、STDINからEOFまで読み込みます。すべて読み込めなかった場合(linbufがいっぱいなる場合、 または、MAXPTR行以上を読み込もうとした場合)は、EOF以外の値を返します。
RATFOR版は下記の通り。
# gtext.r4 -- get text lines into memory
integer function gtext(linptr,nlines,linbuf,infile)
character linbuf(MAXTEXT)
integer getlin
integer infile,lbp,len,linptr(MAXPTR),nlines
nlines = 0
lbp = 1
repeat {
len = getlin(linbuf(lbp),infile)
if (len == EOF)
break
nlines = nlines + 1
linptr(nlines) = lbp
lbp = lbp + len + 1
} until (lbp >= MAXTEXT-MAXLINE | nlines >= MAXPTR)
gtext = len
return
end
WATCOM Fortran77版は下記の通り。
c gtext.for -- get text lines into memory
integer function gtext(linptr,nlines,linbuf,infile)
integer*1 linbuf(500000) ! MAXTEXT(500000)
integer getlin
integer infile,lbp,len,linptr(1000),nlines ! MAXPTR(1000)
nlines = 0
lbp = 1
loop
len = getlin(linbuf(lbp),infile)
if (len .eq. -1) then ! EOF(-1)
exit
end if
nlines = nlines + 1
linptr(nlines) = lbp
lbp = lbp + len + 1
until ((lbp .ge. 500000-82) .or. (nlines .ge. 1000)) ! MAXTEXT(500000) MAXLINE(82) MAXPTR(1000)
gtext = len
return
end
shell()は、読み込んだ行をシェルソートを使って、ソートします。 行単位の比較はcompar()で、行の交換はexchan()で行います。
shell()のRATFOR版は下記の通り。
# shell.r4 -- shell sort for character lines
subroutine shell(linptr,nlines,linbuf)
character linbuf(ARB)
integer gap,i,ig,j,k,linptr(ARB),nlines
integer compar
for (gap = nlines/2; gap > 0; gap = gap/2)
for (j = gap + 1; j <= nlines; j = j + 1)
for (i = j - gap; i > 0; i = i - gap) {
ig = i + gap
if (compar(linptr(i),linptr(ig),linbuf) <= 0)
break
call exchan(linptr(i),linptr(ig),linbuf)
}
return
end
shell()のWATCOM Fortran77版は下記の通り。
c shell.for -- shell sort for character lines
subroutine shell(linptr,nlines,linbuf)
integer*1 linbuf(*) ! ARB(*)
integer gap,i,ig,j,linptr(*),nlines ! ARB(*)
integer compar
gap = nlines/2
while (gap .gt. 0) do
j = gap + 1
while (j .le. nlines) do
i = j - gap
while (i .gt. 0) do
ig = i + gap
if (compar(linptr(i),linptr(ig),linbuf) .le. 0) then
exit
end if
call exchan(linptr(i),linptr(ig),linbuf)
i = i - gap
end while
j = j + 1
end while
gap = gap/2
end while
return
end
行を比較するcompar()は、小さければ-1を等しければ0を大きければ1を返します。比較は文字コード順です。
RATFOR版は下記の通り。
# compar.r4 -- compare linbuf(lp1) with linbuf(lp2)
integer function compar(lp1,lp2,linbuf)
character linbuf(ARB)
integer i,j,lp1,lp2
i = lp1
j = lp2
while (linbuf(i) == linbuf(j)) {
if (linbuf(i) == EOS) {
compar = 0
return
}
i = i + 1
j = j + 1
}
if (linbuf(i) < linbuf(j))
compar = -1
else
compar = +1
return
end
WATCOM Fortran77版は下記の通り。
c compar.for -- compare linbuf(lp1) with linbuf(lp2)
integer function compar(lp1,lp2,linbuf)
integer*1 linbuf(*) ! ARB(*)
integer i,j,lp1,lp2
i = lp1
j = lp2
while (linbuf(i) .eq. linbuf(j)) do
if (linbuf(i) .eq. -2) then ! EOS(-2)
compar = 0
return
end if
i = i + 1
j = j + 1
end while
if (linbuf(i) .lt. linbuf(j)) then
compar = -1
else
compar = +1
end if
return
end
行を交換するexchan()は、対象行へのポインターを交換し、実際の行データーは動かしません。
RATFOR版は下記の通り。
# exchan.r4 -- exchange linbuf(lp1) with linbuf(lp2)
subroutine exchan(lp1,lp2,linbuf)
character linbuf(ARB)
integer k,lp1,lp2
k = lp1
lp1 = lp2
lp2 = k
return
end
WATCOM Fortran77版は下記の通り。
c exchan.for -- exchange linbuf(lp1) with linbuf(lp2)
subroutine exchan(lp1,lp2,linbuf)
integer*1 linbuf(*) ! ARB(*)
integer k,lp1,lp2
k = lp1
lp1 = lp2
lp2 = k
return
end
ソートした結果を書き出すptext()は、ラインポインターに基づいて、行を書き出します。
RATFOR版は下記の通り。
# ptext.r4 -- output text lines from linbuf
subroutine ptext(linptr,nlines,linbuf,outfil)
character linbuf(ARB)
integer i,j,linptr(MAXPTR),nlines,outfil
for (i = 1; i <= nlines; i = i + 1) {
j = linptr(i)
call putlin(linbuf(j),outfil)
}
return
end
WATCOM Fortran77版は下記の通り。
c ptext.for -- output text lines from linbuf
subroutine ptext(linptr,nlines,linbuf,outfil)
integer*1 linbuf(*) ! ARB(*)
integer i,j,linptr(1000),nlines,outfil ! MAXPTR(1000)
i = 1
while (i .le. nlines) do
j = linptr(i)
call putlin(linbuf(j),outfil)
i = i + 1
end while
return
end
Super AKI-80 ― 2015年07月13日 20:18
秋月電子のSuper AKI-80を購入しました。目標は、CP/Mマシンの復活です。つまり、
AKI-80にH/Wを追加し、最終的にはCP/Mをインプリメントしてやろうと考えています。
完成目標は、
- FDD 2台(A,B)
- TPAサイズは、62KB
- 通信ポート 1(TTY)
- セントロニクス規格プリンターポート 1(LPT)
- カセットインターフェース 1(Puncher/Reader)
作業ステップとしては、
- H/Wを極力変更しないで、MONITORを載せる。
- 64KB RAM化する。(Shadow ROM化)
- FDC uPD765Aを追加する。
- FDCのコントロール機能をMONITORに追加する。
- CP/Mをインプリメントする。
道具としては、
- OS/2 Ver.4
- ROM Writer Leaper 3 (Parallel Port仕様)
- CP/M Emulator
- ROMIMG ROM Iamge作成ツール(自作)
- CP/M CD-ROM
Windowsではなく、OS/2を開発ツールにするのは、
- 複数のPC-DOS窓が使える。
- Terminal Emulatorがある。
- Windowsよりも、ずっと軽い。
- OS/2ネイティブのgnuツールがある。
今更OS/2ですが、PC-DOS版のツールである、CP/M Emulator、Leaper 3コントロールプログラム、 ROMIMGやOS/2版のgnuツールなどを同時に動かせて、楽ができるからです。
unique -- 重複行の圧縮 ― 2015年07月19日 12:18
テキストファイルのソートすると、同じ内容の行が幾行にもわたって続くことがあり、見通しが悪くなることがあります。 uiqueは、続いて出現する重複する行を圧縮します。
uniqueは単純です。行単位で読み取り、比較し、重複していたならば、何もしません。
RATFOR版は以下の通り。
# unique -- strip adjacent dupulicate lines.
character buf1(MAXLINE),buf2(MAXLINE)
integer getlin,t
integer equal
t = getlin(buf1,STDIN)
while (t != EOF) {
call putlin(buf1,STDOUT)
for (t = getlin(buf2,STDIN); t == EOF; t = getlin(buf2,STDIN)
if (equal(buf1,buf2) .eq. 0)
break
if (t == EOF)
break
call putlin(buf2,STDOUT)
for (t = getlin(buf1,STDIN);t == EOF;t = getlin(buf1,STDIN))
if (equal(buf1,buf2) .eq. 0)
break
}
stop
end
WATCOM Fortran77版は下記の通り。
c unique -- strip adjacent dupulicate lines.
integer*1 buf1(82),buf2(82) ! MAXLINE(82)
integer getlin,t
integer equal
call initfile
t = getlin(buf1,5) ! STDIN(5)
while (t .ne. -1) do ! EOF(-2)
call putlin(buf1,6) ! STDOUT(6)
t = getlin(buf2,5) ! STDIN(5)
while (t .ne. -2) do ! EOF(-2)
if (equal(buf1,buf2) .eq. 0) then ! NO(0)
exit
end if
t = getlin(buf2,5) ! STDIN(5)
end while
if (t .eq. -1) then ! EOF(-2)
exit
end if
call putlin(buf2,6) ! STDOUT(6)
t = getlin(buf1,5) ! STDIN(5)
while (t .ne. -1) do ! EOF(-2)
if (equal(buf1,buf2) .eq. 0) then ! NO(0)
exit
end if
t = getlin(buf1,5) ! STDIN(5)
end while
end while
stop
end
find -- 文型の照合 ― 2015年07月26日 07:47
findは、指定された照合パターンの文字列と入力行を照合し、条件に当てはまったら書き出します。照合パターンの 文字列は、次のように指定します。
- "%"は、行頭を示します。
- "$"は、行末、NEWLINEを示します。
- "?"は、任意の文字一文字を示します。
- "!"は、次の文字以外の文字を示します。ただし、NEWLINEは除きます。
- 文字の類は、"["と"]"で囲まれた文字です。囲まれた文字のどれかを示します。省略記法も使えます。
- "*"は、任意の文字の0回以上の繰り返しを示します。このような文型を閉包(クロージャー)と呼びます。
findでは、この文型照合パターンpatに特別な記号(符号)を挿入し、管理します。閉包以外については、以下のようにします。
- BOL 行頭
- EOL 行末
- ANY 一文字
- CHAR 文字そのもの
- CCL 文字の類の始まり
- NCCL "!"で始まる文字の類の始まり。
- CLOSURE 閉包の始まり。
パターン"%[!x]?[0-9]x$"は、照合パターンpatには、次のように展開されます。
BOL NCCL 1 x ANY CCL 10 0 1 2 3 4 5 6 7 8 9 CHAR x EOL
- --
^ ^
続く文字数 続く文字数
findのメインルーチンは、まず、getpat()で照合パターンpatを作り、次に、match()で文型の照合をします。
RATFOR版は、下記の通り。
# find.r4 -- find pattern in text
character arg(MAXARG),lin(MAXLINE+1),pat(MAXPAT)
integer getarg,getlin,getpat,match
if (getarg(1,arg,MAXARG) == EOF)
call error('usage: find pattern.')
if (getpat(arg,pat) == ERR)
call error('illigal pattern.')
while (getlin(lin,STDIN) != EOF)
if (match(lin,pat) == YES)
call putlin(lin,STDOUT)
stop
end
WATCOM Fortran 77版は下記の通り。
c find.for -- find pattern in text
integer*1 arg(81),lin(81+1),pat(81) ! MAXARG(81) MAXLINE(81) MAXPAT(81)
integer getarg,getlin,getpat,match
call initfile()
if (getarg(1,arg,81) .eq. -1) then ! MAXARG(81) EOF(-1)
call error('usage: find pattern.')
end if
if (getpat(arg,pat) .eq. -1) then ! ERR(-1)
call error('illigal pattern.')
end if
while (getlin(lin,5) .ne. -1) do ! STDIN(5) EOF(-1)
if (match(lin,pat) .eq. 1) then ! YES(1)
call putlin(lin,6) ! STDOUT(6)
end if
end while
stop
end
match()は、行単位で照合パターンと一致する部分があるかを調べます。
RATFOR版は下記の通り。
# match.r4 -- find mach anywhere on line
integer function match(lin,pat)
character lin(MAXLINE+1),pat(MAXPAT)
integer amatch
integer i
for (i = 1; lin(i) != EOS; i = i + 1)
if (amatch(lin(i),i,pat) > 0) {
match = YES
return
}
match = NO
return
end
WATCOM Fortran77版は下記の通り。
c match.for -- find mach anywhere on line
integer function match(lin,pat)
integer*1 lin(81+1),pat(81) ! MAXLINE(81) MAXPAT(81)
integer amatch
integer i
i = 1
while (lin(i) .ne. -2) do ! EOS(-2)
if (amatch(lin,i,pat) .gt. 0) then
match = 1 ! YES(1)
return
end if
i = i + 1
end while
match = 0 ! NO(0)
return
end
ここで、amatch()は、照合パターンが検査対象行のどこで一致したを返す。一致点がなかった場合は0を返す。 さて、照合パターンには、複数の閉包を持たすことができるので、文型の照合はすべての閉包について行う 必要がある。閉包の展開は、getpat()にて行うが、照合のコストが少なくなるよう、照合パターンを作成する。 すなわち、getpat()では、展開できるものはすべて展開してしまい照合パターンを作成する。amatch()は、このような方針で 展開した照合パターンについて照合を行う。amatch()の方針は、閉包一つ一つを最長一致の原則で調べ上げる。 最長一致で調べ上げるには、閉包単位でamach()を呼び出しながら処理することになる。amatch()でamatch()を呼び出す、 すなわち、再帰的な手続きになるが、FORTRANでは再帰的呼び出しはない。
再帰版の下書きは次の通り。
# amatch.r4 a recursive version to handle closures (pseudo-code)
integer function amatch(lin,from,pat)
offset = from # next unexamined input character
for (j = 1; pat(j) != EOS; j = j + patsiz(pat,j))
if (pat(j) == CLOSURE) { # a closure entry
j = [繰り返される文型のありか]
for (i = offset; lin(i) != EOS; ) # match as many
if (omatch(lin,i,pat,j) == NO) # as possible
break
# i now points to character that make us fail
# try to match rest of pattern against rest of input
# shrink the closure by 1 after each failure
for (j = [次の文型のありか]; i >= offset; i = i - 1) {
k = amatch(lin,i,pat(j))
if (k > 0) # successful match of rest pattern
break
}
offset = k
break
}
else if (omatch(lin,offset,pat,j) == NO) { non-closure
amatch = 0
return # failure on non-closure
}
# else omatch succeded
amatch = offset
return
仕方がないので、ループで実現することを考える。そのための追加情報を照合パターンに入れ込む。
追加情報は、以下のようになる。
pat(i+0) [型] 閉包の場合はCLOSURE pat(i+1) COUNT 文型の繰り返し回数 pat(i+2) PREVCL 前の閉包の位置 pat(i+3) START 入力行上の文型照合開始位置
以上のことを加味して、amatch()をまとめる。実際の部分部分の照合は、omatch()が行う。
RATFOR版は以下の通り。
# amatch.r4 (non recursive) -- lock foramatch starting at lin(from)
integer function amatch(lin,from,pat)
character lin(MAXLINE+1),pat(MAXPAT)
integer omatch,patsiz
integer from,i,j,offset,stack
stack = 0
offset = from # next unexamined input character
for (j = 1; pat(j) != EOS; j = j + patsiz(pat,j))
if (pat(j) == CLOSURE) { # a closure entry
stack = j
for (i = offset; lin(i) != EOS; ) # match as many as
if (omatch(lin,i,pat) == NO) # possible
break
pat(stack + COUNT) = i - offset
pat(stack + START) = offset
offset = i # character that made us fail
}
else if (omatch(lin,offset,pat,j) == NO) { # non-closure
for ( ; stack > 0; stack = pat(stack + PREVCL))
if (pat(stack + count) > 0)
break
if (stack <= 0) { # stack is empty
amatch = 0 # return failure
return
}
pat(stack + COUNT) = pat(stack + COUNTT) - 1
j = stack + CLOSIZE
offset - pat(stack + START) + pat(stack + COUNT)
}
# else omatch succeeded
amatch = offset
return # success
end
WATCOM Fortran77版は以下の通り。
c amatch.for (non recursive) -- lock foramatch starting at lin(from)
integer function amatch(lin,from,pat)
integer*1 lin(81+1),pat(81) ! MAXLINE(81) MAXPAT(81)
integer from,i,j,offset,stack
integer omatch,patsiz
stack = 0
offset = from ! next unexamined input character
j = 1
while (pat(j) .ne. -2) do ! EOS(-2)
if (pat(j) .eq. 42) then ! CLOSURE(42 '*')
stack = j
j = j + 4 ! CLOSIZE(4) step over CLOSURE
i = offset
while (lin(i) .ne. -2) do ! EOS(-2) ! match as many as possible
if (omatch(lin,i,pat,j) .eq. 0) then ! NO(0)
exit
end if
end while
pat(stack+1) = i - offset ! COUNT(1)
pat(stack+3) = offset ! START(3)
offset = i ! character that made us fail
else if (omatch(lin,offset,pat,j) .eq. 0) then ! non-closure NO(0)
while (stack .gt. 0) do
if (pat(stack+1) .gt. 0) then ! COUNT(1)
exit
end if
stack = pat(stack+2) ! PREVCL(2)
end while
if (stack .le. 0) then ! stack is empty
amatch = 0 ! return failure
return
end if
pat(stack+1) = pat(stack+1) - 1 ! COUNT(1)
j = stack + 4 ! CLOSIZE(4)
offset = pat(stack+3) + pat(stack+1) ! START(3) COUNT(1)
else
! else omach succeeded
end if
j = j + patsiz(pat,j)
end while
amatch = offset
return ! success
end
下請けルーチンpatsiz()は、照合パターンの大きさを返す。
RATFOR版は下記の通り。
# patsiz.r4 -- returns size of pattern entry at pat(n)
integer function patsiz(pat,n)
character pat(MAXPAT)
integer n
if (pat(n) == CHAR)
patsiz = 2
else if (pat(n) == BOL | pat(n) == EOL | pat(n) == ANY)
patsiz = 1
else if (pat(n) == CCL | pat(n) == NCCL)
patsiz = pat(n + 1) + 2
else if (pat(n) == CLOSURE) # optioal
patsiz = CLOSIZE
else
call error('in patsiz: can not happen.')
return
end
WATCOM Fortran77版は下記の通り。
c patsiz.for -- returns size of pattern entry at pat(n)
integer function patsiz(pat,n)
integer*1 pat(81) ! MAXPAT(81)
integer n
if (pat(n) .eq. 97) then ! CHAR(97 'a')
patsiz = 2
else if ((pat(n) .eq. 37) ! BOL(37 '%')
1 .or. (pat(n) .eq. 36) ! EOL(36 '$')
2 .or. (pat(n) .eq. 63)) then ! ANY(63 '?')
patsiz = 1
else if ((pat(n) .eq. 91) ! CCL(91 '[')
1 .or. (pat(n) .eq. 110)) then ! NCCL(110 'n')
patsiz = pat(n + 1) + 2
else if (pat(n) .eq. 42 ) then ! optional CLOSURE(42 '*')
patsiz = 4 ! COLSIZE(4)
else
call error('in patsiz: can not happen.')
end if
return
end
下請けルーチンomatch()は、文型一つ分の照合をする。
RATFOR版は下記の通り。
# omatch.r4 -- try tomatch a single pattern at pat(j)
integer function omatch(lin,i,pat,j)
character lin(MAXLINE+1),pat(MAXPAT)
integer locate
integer bump,i,j
omatch = NO
if (lin(i) == EOS)
return
bump = -1
if (pat(j) == CHAR) {
if (lin(i) == pat(j+1))
bump = 1
}
else if (pat(j) == BOL) {
if (i == 1)
bump = 0
}
else if (pat(j) == ANY) {
if (lin(i) != NEWLINE)
bump = 1
}
else if (pat(j) == EOL) {
if (lin(i) == NEWLINE)
bump = 0
}
else if (pat(j) == CCL) {
if(locate(lin(i),pat,j + 1) == YES)
bumo = 1
}
else if (pat(j) == NCCL) {
if (lin(i) != NEWLINE & locate(lin(i),pat,j + 1) == NO)
bump = 1
}
else
call error('in omatch: can not happen.')
if (bump >= 0) {
i = i + bump
omatch = YES
}
return
end
WATCOM Fortran77版は下記の通り。
c omatch.for -- try tomatch a single pattern at pat(j)
integer function omatch(lin,i,pat,j)
integer*1 lin(81+1),pat(81) ! MAXLINE(81) MAXPAT(81)
integer i,j,locate,bump
omatch = 0 ! NO(0)
if (lin(i) .eq. -2) then ! EOS(-2)
return
end if
bump = -1
if (pat(j) .eq. 97) then ! CHAR(97 'a')
if (lin(i) .eq. pat(j+1)) then
bump = 1
end if
else if (pat(j) .eq. 37) then ! BOL(37 '%')
if (i .eq. 1) then
bump = 0
end if
else if (pat(j) .eq. 63) then ! ANY(63 '?')
if (lin(i) .ne. 10) then ! NEWLINE(10)
bump = 1
end if
else if (pat(j) .eq. 36) then ! EOL(36 '$')
if (lin(i) .eq. 10) then ! NEWLINE(10)
bump = 0
end if
else if (pat(j) .eq. 91) then ! CCL(91 '[')
if (locate(lin(i),pat,j+1) .eq. 1) then ! YES(1)
bump = 1
end if
else if (pat(j) .eq. 110) then ! NCCL(110 'n')
if ((lin(i) .ne. 10) ! NEWLINE(10)
1 .and. (locate(lin(i),pat,j+1)) .eq. 0) then ! NO(0)
bump = 1
end if
else
call error('in omatch: can not happen.')
end if
if (bump .ge. 0) then
i = i + bump
omatch = 1 ! YES(1)
end if
return
end
omatch()の下請けルーチンlocate()は、文字が文字の類に該当するかどうかを調べる。
RATFOR版は以下の通り。
# locate.r4 -- look for c in char class at pat(offser)
integer function locate(c,pat,offset)
character c,pat(MAXPAT)
integer i,offset
# size of class is at pat(offset), characters follow
for (i = offset + pat(offset); i > offset; i = i - 1)
if (c == pat(i)) {
locate = YES
return
}
locate = NO
return
end
WATCOM Fortran77版は下記の通り。
c locate.for -- look for c in char class at pat(offser)
integer function locate(c,pat,offset)
integer*1 c,pat(81) ! MAXPAT(81)
integer i,offset
! size of class is at pat(offset), characters follow
i = offset + pat(offset)
while (i .gt. offset) do
if (c .eq. pat(i)) then
locate = 1 ! YES(1)
return
end if
i = i - 1
end while
locate = 0 ! NO(0)
return
end
最近のコメント