一百個例題 (81 ~ 85)
Ching-Tang Tseng
Hamilton, New Zealand
3 October 2024
FORTH:慶的世界。 本網頁為中華民國(Republic Of China)FORTH語言協會 永久性網頁
2024年10月2日 星期三
第(81)個範例是中國餘式定理或簡稱為韓信點兵問題的程式解法。
問題不是很深奧，範例則在顯示程式語法的美化與優化。
美化，指的是程式的書寫格式就跟口語的問題完全相同，你問什麼問題，程式就能寫成完全相應的格式，一目了然。能這樣寫，得力於 Forth 程式語言從被發明起就具有一個兩數除完後只獲得餘數的指令 MOD ，1980 年代出現的任何程式語言都還沒有這個數學運算指令，只有 Forth 具有，後來其它的程式語言才跟進採用。設計求解韓信點兵問題的程式就能用得上 MOD 運算。美化的結果，是根本不用解釋程式在作什麼，一看就知道程式是在解中國餘式定理的問題。
優化，指的是如何將冗長的固定迴路優化成能最快速的達到目的，不必以逐步只增量 1 的方式來執行完固定迴路。範例程式中的第二個 turbo 程式 test2 就在做優化的事情。優化的項目有三個，一是經過解析問題後發現，固定迴路的起始值可以不必從 1 開始，而可以是從挑選韓信點兵問題中的最大數字作為開始，例如本範例中的最大數字條件是除以 19 後餘 5，那麼固定迴路的起始值就是 19 + 5 。漂亮的語法設計，還可以直接將起始值就寫成 19 + 5 。
二是固定迴路的 step 步進量可以設定成不是每次只能增量 1 ，因為解析問題後發現，固定迴路的步進增量可以是已經挑選的最大數字，例如本範例中的 19 。加大步進量，當然能大量減少所需執行之固定迴路的次數。
三是一旦固定迴路覓得了第一個答案，固定迴路就可以結束不再執行，這樣的設計技巧，全世界也只有我設計的 ABC Forth 系統可以輕易辦到。它的用法，就是在跳出固定迴路所去的地方執行一次 run 2drop 指令。能這樣設計，起因於我將系統執行固定迴路時的兩個指標值放在數據堆疊上，不做固定迴路了，直接將兩個指標值丟棄便可。這樣的優化方式，一旦在出現覓得答案時執行迴路的次數遠遠小於固定迴路的上限次數時，優化量是非常可觀的，此例中是個位數的幾次與一百億次之差別，非常可觀。
求解數學問題，首先重視解答是否存在(Exist)？ 在本範例中，當所給予的條件有矛盾時，答案有可能不存在，而且，實質的問題也在於韓信不可能點出百億個名額的兵來。所以，程式在遇到不合理狀況時，當然也必須給出『所給問題不恰當』(" Question is inexact! ") 的輸出解答來。
另外一個求解數學問題也必須重視的條件是解答是否唯一(Unique)？ 解析問題的結果顯示覓得的第一個解答之所有的整數倍數都是解答，因此，輸出的答案就得設計成是數列表示的方式。
:
問題不是很深奧，範例則在顯示程式語法的美化與優化。
美化，指的是程式的書寫格式就跟口語的問題完全相同，你問什麼問題，程式就能寫成完全相應的格式，一目了然。能這樣寫，得力於 Forth 程式語言從被發明起就具有一個兩數除完後只獲得餘數的指令 MOD ，1980 年代出現的任何程式語言都還沒有這個數學運算指令，只有 Forth 具有，後來其它的程式語言才跟進採用。設計求解韓信點兵問題的程式就能用得上 MOD 運算。美化的結果，是根本不用解釋程式在作什麼，一看就知道程式是在解中國餘式定理的問題。
優化，指的是如何將冗長的固定迴路優化成能最快速的達到目的，不必以逐步只增量 1 的方式來執行完固定迴路。範例程式中的第二個 turbo 程式 test2 就在做優化的事情。優化的項目有三個，一是經過解析問題後發現，固定迴路的起始值可以不必從 1 開始，而可以是從挑選韓信點兵問題中的最大數字作為開始，例如本範例中的最大數字條件是除以 19 後餘 5，那麼固定迴路的起始值就是 19 + 5 。漂亮的語法設計，還可以直接將起始值就寫成 19 + 5 。
二是固定迴路的 step 步進量可以設定成不是每次只能增量 1 ，因為解析問題後發現，固定迴路的步進增量可以是已經挑選的最大數字，例如本範例中的 19 。加大步進量，當然能大量減少所需執行之固定迴路的次數。
三是一旦固定迴路覓得了第一個答案，固定迴路就可以結束不再執行，這樣的設計技巧，全世界也只有我設計的 ABC Forth 系統可以輕易辦到。它的用法，就是在跳出固定迴路所去的地方執行一次 run 2drop 指令。能這樣設計，起因於我將系統執行固定迴路時的兩個指標值放在數據堆疊上，不做固定迴路了，直接將兩個指標值丟棄便可。這樣的優化方式，一旦在出現覓得答案時執行迴路的次數遠遠小於固定迴路的上限次數時，優化量是非常可觀的，此例中是個位數的幾次與一百億次之差別，非常可觀。
求解數學問題，首先重視解答是否存在(Exist)？ 在本範例中，當所給予的條件有矛盾時，答案有可能不存在，而且，實質的問題也在於韓信不可能點出百億個名額的兵來。所以，程式在遇到不合理狀況時，當然也必須給出『所給問題不恰當』(" Question is inexact! ") 的輸出解答來。
另外一個求解數學問題也必須重視的條件是解答是否唯一(Unique)？ 解析問題的結果顯示覓得的第一個解答之所有的整數倍數都是解答，因此，輸出的答案就得設計成是數列表示的方式。
:
\ Chinese Remainder Theorem
\ simple version
integer i
: test1
basic
10 for i = 1 to 10000000000
20 if ( i mod 11 = 1 ) and ( i mod 13 = 2 )
and ( i mod 15 = 3 ) and ( i mod 17 = 4 )
and ( i mod 19 = 5 )
then 60
30 next i
40 print " Question is inexact! "
50 goto 80
60 run 2drop
70 print " Answer = N * " ; i ; " , N = 1, 2, 3, ... "
80 end ;
\ turbo version: How dose it speeded up? You got to know that.
: test2
basic
10 for i = 19 + 5 to 10000000000 step 19
20 if ( i mod 11 = 1 ) and ( i mod 13 = 2 )
and ( i mod 15 = 3 ) and ( i mod 17 = 4 )
and ( i mod 19 = 5 )
then 60
30 next i
40 print " Question is inexact! "
50 goto 80
60 run 2drop
70 print " Answer = N * " ; i ; " , N = 1, 2, 3, ... "
80 end ;
test1
test2
\ 80386 ciforth 5.1
\ fload chinar.f
\ I : ISN'T UNIQUE
\ Answer = N * 346413 , N = 1, 2, 3, ...
\ Answer = N * 346413 , N = 1, 2, 3, ... OK
第(82)個範例，是一個從 16 位元時代的軟體浮點四則運算程式改成能在 64 位元 Wina64 系統中執行的發展記錄。
這個範例跟 Win32Forth 系統無關，請不要試圖載入。
程式雖然受限，卻值得介紹，讓大家了解純軟體的浮點系統是如何發展出來的，日後，有興趣從事於這方面的發展者，有此程式可供參考，就能知道方向，自己開發。
介紹之前，我先行介紹有關 ciForth 的大要。此系統的主要精神全來自最早的公益系統： Fig-Forth 。系統的長期作者是荷蘭人 Albert Ven Der Host ，他改寫出來的組合語言源碼，完全公開，並為所有的作業系統寫這種 Forth 。在 Windows’ OS 中者稱為 Wina ，64 位元者加稱 Wina64 。在 Linux OS 中者，依例稱 Lina32 與 Lina64 ，在 Mac OS 中則稱 Xina ，但尚未發展出 Xina64 ，只有 Xina32 。至於他在 16 位元 DOS 時代以前的成就，我就不介紹了。
上述系統我都跑過，能明確指出，只有在 Linux OS 下的版本，性能才最完整， Wina32 則尚可， Wina64 則功能不全，因操作檔案規格的檔頭部份尚未開發完整，故無法正確執行出 SAVE-SYSTEM 的功效，我若用它發展，成果便無法固定，所以用過後停用。在 Mac OS 上的情況更糟，只有 32 位元可用，編輯環境又很差，作業系統的資源還不公開，發展困難，我跑通後就也停用了。
換言之，若要採用這個系統，在 Linux OS 中使用無論是 Lina32 或 Lina64 都很恰當。我一直採用這個系統，現在，也只使用 Lina64 。
2017 年，為了測試 Wina64 的性能，我下了很大的功夫開發純軟體浮點(Software Floating Point)系統，就是這個範例。他的源碼是 16 位元時代的產品，作者姓名為縮寫的 BNE ，範例中留有我發展前後的所有記錄，所有尾部添加的說明中，若出現三個星號 \ *** ，就是我必須修改後才能適用於 64 位元環境的必要修正。
許多寬列的說明，以及後來我放棄掉，卻仍收集在 \S 以後的額外程式，都是我個人的發展記錄，值得保留，我才留下。這些記錄全都具有參考價值，常人很難作得出來，是我下過功夫讀懂、試通程式後的直接體會。做這種事情，若沒有幾十年的 Forth 使用能力，很難完成，因為幾十年來的 Forth 變革，造成指令規格數度大量改變，我一直在用，才知道怎麼改才改得成。
另外，這套軟體浮點，是二進制的浮點系統，不是我獨創的那種十進制的浮點系統。用軟體來發展這樣的系統，就必須要設計出大量的二進制換算程式，執行起來當然就非常的慢，輸入與輸出時，數字都得轉換，也很難轉換得妥當。還有，此作者為了表現能完全模擬硬體數學運算處理器的功能，特別設計了 8 個浮點數的獨立堆疊，結果程式中使用起來差一個，我就只好改成 9 個，省去麻煩。
原設計中也大量使用局部變數，我看不順眼，也全改了，就用普通變數的宣告方式取代，改完後測試，跑起來都無問題了。
此系統的浮點數放在堆疊上的格式，是最重要的依據，設計浮點系統時，任何人都必須首先將此規格固定，才能有所作為。我在追蹤完程式後才能確定：
\ Floating point representation on floating point stack:
\ 0 upper mantissa
\ 1 lower mantissa
\ 2 exponent: MSB = sign of mantissa, others = signed exponent
這一段文字，在整個範例中最為重要。
德國人賣的 iForth 系統，號稱其浮點數具有雙整數位數的精確度，我在國際論壇與該系統作者對談過系統的設計基礎，對方明講，精確度高的功能都是叫用 C 的庫存程式完成的，而且他表示我用 Lina64 無法完成同樣的叫用，我便謝完離開。其實，那有叫用不了的問題？我在發展系統時，不是從編譯完後的 Lina64 開始，而是從它的組合語言程式部分就開始設計自己的程式，那麼，組合語言怎麼不能叫用 C 的庫存？當然可以。只是我不喜歡使用 C 的東西，他能用 C 叫 C ，我也能用組合語言叫 C，當然就可以辦到與他一樣的設計。實際上，根據我改好的這個範例程式顯示，我寧可只用 Forth ，不去叫用 C 。
不久前，我在 20240710 貼於本網頁的全用圖表展示式文章『設計浮點系統』中顯示，只用四個畫面的寬鬆程式，就能設計出浮點系統。實際上，我在 Lina64 上自建的浮點系統就是用這麼精簡的設計完成的。另外，本範例的程式中沒有提供以科學數字方式表示的浮點數輸出/輸入之處裡方法，也不容易設計，所以我也沒有採用它來設計浮點系統，只做了單純的研究。
:
這個範例跟 Win32Forth 系統無關，請不要試圖載入。
程式雖然受限，卻值得介紹，讓大家了解純軟體的浮點系統是如何發展出來的，日後，有興趣從事於這方面的發展者，有此程式可供參考，就能知道方向，自己開發。
介紹之前，我先行介紹有關 ciForth 的大要。此系統的主要精神全來自最早的公益系統： Fig-Forth 。系統的長期作者是荷蘭人 Albert Ven Der Host ，他改寫出來的組合語言源碼，完全公開，並為所有的作業系統寫這種 Forth 。在 Windows’ OS 中者稱為 Wina ，64 位元者加稱 Wina64 。在 Linux OS 中者，依例稱 Lina32 與 Lina64 ，在 Mac OS 中則稱 Xina ，但尚未發展出 Xina64 ，只有 Xina32 。至於他在 16 位元 DOS 時代以前的成就，我就不介紹了。
上述系統我都跑過，能明確指出，只有在 Linux OS 下的版本，性能才最完整， Wina32 則尚可， Wina64 則功能不全，因操作檔案規格的檔頭部份尚未開發完整，故無法正確執行出 SAVE-SYSTEM 的功效，我若用它發展，成果便無法固定，所以用過後停用。在 Mac OS 上的情況更糟，只有 32 位元可用，編輯環境又很差，作業系統的資源還不公開，發展困難，我跑通後就也停用了。
換言之，若要採用這個系統，在 Linux OS 中使用無論是 Lina32 或 Lina64 都很恰當。我一直採用這個系統，現在，也只使用 Lina64 。
2017 年，為了測試 Wina64 的性能，我下了很大的功夫開發純軟體浮點(Software Floating Point)系統，就是這個範例。他的源碼是 16 位元時代的產品，作者姓名為縮寫的 BNE ，範例中留有我發展前後的所有記錄，所有尾部添加的說明中，若出現三個星號 \ *** ，就是我必須修改後才能適用於 64 位元環境的必要修正。
許多寬列的說明，以及後來我放棄掉，卻仍收集在 \S 以後的額外程式，都是我個人的發展記錄，值得保留，我才留下。這些記錄全都具有參考價值，常人很難作得出來，是我下過功夫讀懂、試通程式後的直接體會。做這種事情，若沒有幾十年的 Forth 使用能力，很難完成，因為幾十年來的 Forth 變革，造成指令規格數度大量改變，我一直在用，才知道怎麼改才改得成。
另外，這套軟體浮點，是二進制的浮點系統，不是我獨創的那種十進制的浮點系統。用軟體來發展這樣的系統，就必須要設計出大量的二進制換算程式，執行起來當然就非常的慢，輸入與輸出時，數字都得轉換，也很難轉換得妥當。還有，此作者為了表現能完全模擬硬體數學運算處理器的功能，特別設計了 8 個浮點數的獨立堆疊，結果程式中使用起來差一個，我就只好改成 9 個，省去麻煩。
原設計中也大量使用局部變數，我看不順眼，也全改了，就用普通變數的宣告方式取代，改完後測試，跑起來都無問題了。
此系統的浮點數放在堆疊上的格式，是最重要的依據，設計浮點系統時，任何人都必須首先將此規格固定，才能有所作為。我在追蹤完程式後才能確定：
\ Floating point representation on floating point stack:
\ 0 upper mantissa
\ 1 lower mantissa
\ 2 exponent: MSB = sign of mantissa, others = signed exponent
這一段文字，在整個範例中最為重要。
德國人賣的 iForth 系統，號稱其浮點數具有雙整數位數的精確度，我在國際論壇與該系統作者對談過系統的設計基礎，對方明講，精確度高的功能都是叫用 C 的庫存程式完成的，而且他表示我用 Lina64 無法完成同樣的叫用，我便謝完離開。其實，那有叫用不了的問題？我在發展系統時，不是從編譯完後的 Lina64 開始，而是從它的組合語言程式部分就開始設計自己的程式，那麼，組合語言怎麼不能叫用 C 的庫存？當然可以。只是我不喜歡使用 C 的東西，他能用 C 叫 C ，我也能用組合語言叫 C，當然就可以辦到與他一樣的設計。實際上，根據我改好的這個範例程式顯示，我寧可只用 Forth ，不去叫用 C 。
不久前，我在 20240710 貼於本網頁的全用圖表展示式文章『設計浮點系統』中顯示，只用四個畫面的寬鬆程式，就能設計出浮點系統。實際上，我在 Lina64 上自建的浮點系統就是用這麼精簡的設計完成的。另外，本範例的程式中沒有提供以科學數字方式表示的浮點數輸出/輸入之處裡方法，也不容易設計，所以我也沒有採用它來設計浮點系統，只做了單純的研究。
:
\ SFP.F
\ test in wina64 ok 20170616
1 LOAD
WANT DUMP
\ Floating point emulation 11/02 BNE
\ include locals.fth
\ anew floatingpoint
\ ANS Forth using CORE, CORE EXT and DOUBLE wordsets.
\ Rev 0. See bottom for rev history.
\ Floating point representation on floating point stack:
\ 0 upper mantissa
\ 1 lower mantissa
\ 2 exponent: MSB = sign of mantissa, others = signed exponent
10 CONSTANT maxdepth \ *** 8 --> 10
3 CELLS CONSTANT b/float
CREATE fstak maxdepth b/float * ALLOT \ floating point stack
VARIABLE fsp \ stack pointer
VARIABLE sigdigits \ # of digits to display after decimal
VARIABLE ferror \ last seen error
CREATE fpad b/float ALLOT \ temporary float variable
HEX
\ 10000 0= [IF] 10 [ELSE] 20 [THEN] CONSTANT bits/cell \ 16-bit or 32-bit Forth
40 CONSTANT bits/cell \ ***
DECIMAL
bits/cell 1- 602 1000 */ CONSTANT maxdig \ max decimal digits that fit in double
-1 1 RSHIFT DUP CONSTANT &unsign INVERT CONSTANT &sign \ 7F... 80...
&sign 1 RSHIFT CONSTANT &esign \ 40...
\ ------------------------------------------------------------------------------
\ Low level math you could CODE for better speed
\ : DLSHIFT >R SWAP DUP R@ LSHIFT SWAP 8 CELLS R@ - RSHIFT ROT R> LSHIFT OR ; \ ***
\ : DRSHIFT >R DUP R@ RSHIFT SWAP 8 CELLS R@ - LSHIFT ROT R> RSHIFT OR SWAP ; \ ***
\ : D2/ 1 DRSHIFT ; \ ***
HEX
: D2/
DUP 1 AND
IF 2/ SWAP 2/ 8000000000000000 OR SWAP
ELSE 2/ SWAP 2/ 7FFFFFFFFFFFFFFF AND SWAP
THEN
;
DECIMAL
: UD2/ ( d -- d' )
D2/ &unsign AND ;
\ : 0MAX ( n1 -- n2 ) DUP 0 < IF DROP 0 THEN ; \ ***
: frshift ( count 'man -- ) \ right shift mantissa
SWAP 0 MAX bits/cell 2* MIN \ ***
>R DUP 2@ R> 0
?DO UD2/ LOOP ROT 2! ;
: exp>sign ( exp -- exp' sign )
DUP &unsign AND \ mask off exponent
DUP &esign AND 2* OR \ sign extend exponent
SWAP &sign AND ; \ get sign of mantissa
: sign>exp ( exp sign -- exp' )
SWAP &unsign AND OR ;
: +ex ( n1 offset -- n1' ) \ bump n1 but preserve its MSB
SWAP exp>sign >R + R> sign>exp ;
\ : D2* 1 DLSHIFT ; \ ***
: D2* 2DUP D+ ;
: T2* ( triple -- triple' )
D2* ROT DUP 0< 1 AND >R 2* ROT ROT R> 0 D+ ;
: 0<> 0= 0= ; \ ***
: T2/ ( triple -- triple' )
OVER 1 AND 0<> &sign AND >R D2/ ROT \ MHL|C
1 RSHIFT R> OR ROT ROT ;
: 2>R POSTPONE SWAP POSTPONE >R POSTPONE >R ; IMMEDIATE \ ***
: 2R> POSTPONE R> POSTPONE R> POSTPONE SWAP ; IMMEDIATE \ ***
: 2R@ POSTPONE 2R> POSTPONE 2DUP POSTPONE 2>R ; IMMEDIATE \ ***
: T+ ( t1 t2 -- t3 )
2>R >R ROT 0 R> 0 D+ 0 2R> D+
ROT >R D+ R> ROT ROT ;
: *norm ( triple exp -- double exp' ) \ normalize triple
>R BEGIN DUP 0< 0=
WHILE T2* R> 1- >R
REPEAT &sign 0 0 T+ \ round
ROT DROP R> ;
\ ------------------------------------------------------------------------------
\ Parameter indicies
: 'rx ( ofs -- addr ) fsp @ 3 * + CELLS fstak + ;
: 'm1 ( -- addr ) -3 'rx ; \ -> 1st stack mantissa
: 'm2 ( -- addr ) -6 'rx ; \ -> 2nd stack mantissa
: 'm3 ( -- addr ) -9 'rx ; \ -> 3rd stack mantissa \ *** -6 -->-9
: 'e1 ( -- addr ) -1 'rx ; \ -> 1st stack exponent
: 'e2 ( -- addr ) -4 'rx ; \ -> 2nd stack exponent
: 'e3 ( -- addr ) -7 'rx ; \ -> 3nd stack exponent \ *** added
: fmove ( a1 a2 -- ) b/float MOVE ;
: m1get ( addr -- ) 'm1 fmove ; \ move to M1
: m1sto ( addr -- ) 'm1 SWAP fmove ; \ move from M1
: expx1 ( -- exp sign ) 'e1 @ exp>sign ;
: expx2 ( -- exp sign ) 'e2 @ exp>sign ;
\ ------------------------------------------------------------------------------
\ For testing:
\ : f? 'm1 2@ UD2/ D>F expx1 IF FNEGATE THEN
\ &sign OR 1+ S>F 2e0 FLN f* FEXP F* FS. ;
\ 20 SET-PRECISION : f?? FSWAP f? FSWAP f? ;
\ : fd fstak fsp @ b/float * DUMP ; \ dump stack
\ ------------------------------------------------------------------------------
\ A normalized float has an unsigned mantissa with its MSB = 1
: normalize ( -- )
'm1 2@ 2DUP OR 0=
IF 2DROP \ Zero is a special case.
ELSE expx1 >R >R
BEGIN DUP 0< 0= \ not normalized?
WHILE D2* R> 1- >R \ shift mantissa left
REPEAT 'm1 2!
R> R> sign>exp 'e1 !
THEN ;
\ ------------------------------------------------------------------------------
\ Floating Point Words
: F2* ( fs: r1 -- r3 ) 'e1 @ 1 +ex 'e1 ! ;
: F2/ ( fs: r1 -- r3 ) 'e1 @ -1 +ex 'e1 ! ;
: PRECISION ( -- n ) sigdigits @ ;
: SET-PRECISION ( n -- ) maxdig MIN sigdigits ! ;
: FCLEAR ( -- ) 0 fsp ! 0 ferror ! ;
: FDEPTH ( -- ) fsp @ ;
: FDUP ( fs: r -- r r ) 1 fsp +! 'm2 m1get ;
: FDROP ( fs: r -- ) -1 fsp +! ;
: FNEGATE ( fs: r1 -- r3 ) 'e1 @ &sign XOR 'e1 ! ;
: D>F ( d -- | -- r ) FDUP DUP 0< IF DNEGATE &sign ELSE 0 THEN
'e1 ! 'm1 2! normalize ;
: F>D ( -- d | r -- ) expx1 >R DUP &esign AND
IF NEGATE &unsign AND 'm1 frshift 'm1 2@ R> IF DNEGATE THEN
ELSE R> 2DROP -1 &unsign 1 ferror ! \ overflow: return maxdint
THEN FDROP ;
: S>F ( n -- | -- r ) S>D D>F ;
: FLOAT+ ( n1 -- n2 ) b/float + ;
: FLOATS ( n1 -- n2 ) b/float * ;
: F@ ( a -- | -- r ) FDUP m1get ;
: F! ( a -- | r -- ) m1sto FDROP ;
: F0= ( -- t | r -- ) 'm1 2@ OR 0= FDROP ;
: F0< ( -- t | r -- ) 'e1 @ 0< FDROP ;
: FLOOR ( fs: r1 -- r2 ) F>D DUP 0< IF -1 S>D D+ THEN D>F ;
: FABS ( fs: r1 -- r3 ) 'e1 @ 0< IF FNEGATE THEN ;
: FALIGN ( -- ) ALIGN ;
: FALIGNED ( addr -- addr ) ALIGNED ;
: FSWAP ( fs: r1 r2 -- r2 r1 ) 'm1 fpad fmove 'm2 m1get fpad 'm2 fmove ;
: FOVER ( fs: r1 r2 -- r1 r2 r3 ) 1 fsp +! 'm3 m1get ;
\ : FPICK ( n -- ) ( fs: -- r ) 1 fsp +! 1+ -3 * 'rx m1get ;
: FPICK ( n -- ) ( f: -- r )
1 fsp +! 2 + b/float * 'rx m1get ; ( ** was BUG ) \ ***
: FNIP ( fs: r1 r2 -- r2 ) FSWAP FDROP ;
: FROT ( fs: r1 r2 r3 -- r2 r3 r1 )
'm3 fpad fmove 'm2 'm3 b/float 2* MOVE fpad m1get ;
: F+ ( fs: r1 r2 -- r3 )
FDUP F0= IF FDROP EXIT THEN \ r2 = 0
FOVER F0= IF FNIP 'e1 @ 0< IF FNEGATE THEN EXIT THEN \ r1 = 0
expx1 >R expx2 >R - DUP 0<
IF NEGATE 'm1 frshift 0 \ align exponents
ELSE DUP 'm2 frshift
THEN 'e2 @ +
'm2 2@ R> IF DNEGATE -1 ELSE 0 THEN
'm1 2@ R> IF DNEGATE -1 ELSE 0 THEN
T+ DUP >R ( exp L M H | sign )
DUP IF T2/ IF DNEGATE THEN 'm2 2! 1+
ELSE DROP 'm2 2!
THEN R> &sign AND sign>exp 'e2 !
FDROP normalize ;
: F- ( fs: r1 r2 -- r3 ) FNEGATE F+ ;
: F< ( -- t ) ( F: r1 r2 -- ) FOVER FOVER F- F0< ;
: FROUND ( fs: r1 -- r2 )
expx1 >R DUP NEGATE 1- 'm1 frshift \ convert to half steps
'm1 2@ 1 0 D+ \ round
'm1 2! R> sign>exp 'e1 ! normalize ; \ re-float
: FMIN ( F: r1 r2 -- rmin ) FOVER FOVER F<
IF FDROP ELSE FNIP THEN ;
: FMAX ( F: r1 r2 -- rmax ) FOVER FOVER F<
IF FNIP ELSE FDROP THEN ;
\ 1. VALUE
: VALUE
CREATE , \ ( n -- )
DOES> @ \ ( -- n )
;
: VALUES ( N -- )
0 ?DO 0 VALUE LOOP ;
: TO ( N -- )
' >BODY STATE @
IF POSTPONE LITERAL POSTPONE !
ELSE !
THEN ; IMMEDIATE
: +TO ( N -- )
' >BODY STATE @
IF POSTPONE LITERAL POSTPONE +!
ELSE +!
THEN ; IMMEDIATE
0 VALUE L1
0 VALUE U1
0 VALUE L2
0 VALUE U2
: PICK 1+ CELLS DSP@ + @ ; \ ***
: F* ( fs: r1 r2 -- r3 )
'm1 2@ TO U1 TO L1 'm2 2@ TO U2 TO L2 \ { L1 U1 L2 U2 -- } ***
L1 L2 OR
IF L1 L2 UM* &sign 0 D+ NIP \ round
U1 U2 UM*
L1 U2 UM* 0 T+
L2 U1 UM* 0 T+
ELSE 0 U1 U2 UM* \ lower parts are 0
THEN 2DUP OR 3 PICK OR \ zero?
IF expx1 >R expx2 >R + bits/cell 2* + *norm
R> R> XOR sign>exp 'e2 ! 'm2 2!
ELSE DROP D>F \ zero result
THEN FDROP ;
: DU< ROT 2DUP = IF 2DROP U< EXIT THEN 2SWAP 2DROP SWAP U< ; \ ***
: D- ( d1 d2 -- d1-d2 ) DNEGATE D+ ; \ ***
: -ROT ROT ROT ; \ ***
: U> SWAP U< ; \ ***
: F/ ( fs: r1 r2 -- r3 )
FDUP F0=
IF FDROP -1 -1 'm1 2! 2 ferror ! \ div by 0, man= umaxint
'e1 @ &sign AND &sign 2/ 1- OR 'e1 ! \ exponent = maxint/2
ELSE 'm1 2@ 'm2 2@ DU< IF 1 'm2 frshift THEN \ divisor <= dividend
'm1 CELL+ @
IF 'm2 2@ UD2/ 'm1 2@ UD2/ \ max divisor = dmaxint
0 0 PAD 2!
bits/cell 2* 1+ 0 \ long division
DO 2OVER 2OVER DU< \ double/double
IF 0
ELSE 2DUP 2>R D- 2R> 1 \ a b --> a-b b
THEN 0 PAD 2@ D2* D+ PAD 2!
2SWAP D2* 2SWAP
LOOP DU< 0= 1 AND 0 \ round
PAD 2@ D+
bits/cell 2*
ELSE 0 'm2 2@ 'm1 @ DUP >R UM/MOD \ 0 rem quot | divisor
-ROT R@ UM/MOD -ROT R> 1 RSHIFT U> IF 1 0 D+ THEN \ round
bits/cell 2*
THEN expx2 >R expx1 >R - SWAP -
>R 'm2 2! R> R> R> XOR sign>exp 'e2 !
FDROP
THEN ;
: F~ ( f: r1 r2 r3 -- ) ( -- flag ) \ f-proximate
FDUP F0< \ Win32forth version
IF FABS FOVER FABS 3 FPICK FABS F+ F* \ r1 r2 r3*(r1+r2)
FROT FROT F- FABS FSWAP F<
ELSE FDUP F0=
IF FDROP F- F0=
ELSE FROT FROT F- FABS FSWAP F<
THEN
THEN ;
\ For fixed-width fields, it makes sense to use these words for output:
\ fsplit ( F: r -- ) ( fracdigits -- sign Dint Dfrac )
\ Converts to integers suitable for pictured numeric format.
\ Fracdigits is the number of digits to the right of the decimal.
\ .digits ( UD fracdigits -- )
\ Outputs a fixed number of digits
: fsplit ( F: r -- ) ( fracdigits -- sign Dint Dfrac )
>R expx1 NIP FABS \ int part must fit in a double
FDUP F>D 2DUP D>F F- \ get int, leave frac
2 0 R> 0
?DO D2* 2DUP D2* D2* D+ LOOP \ 2 * 10^precision
D>F F* F>D 1 0 D+ UD2/ ; \ round
: .digits ( UD cnt -- )
0 ?DO # LOOP 2DROP ;
\ Nonstandard: PRECISION is the number of digits after the decimal, not the
\ total number of digits.
\ : 0> 0 > ; \ ***
: (F.) ( F: r -- ) ( -- addr len )
<# FDEPTH 0 > 0= IF #> EXIT THEN \ empty stack -> blank \ *** 0< --> 0 <
PRECISION fsplit
PRECISION .digits
PRECISION IF [CHAR] . HOLD THEN
#S SIGN #> ;
: F. ( F: r -- ) (F.) TYPE SPACE ;
: FCONSTANT ( -name- ) ( F: r -- ) \ compile time
( F: -- r ) \ runtime
CREATE HERE F! b/float ALLOT DOES> F@ ;
: FVARIABLE ( -name- ) \ compile time
( F: -- r ) \ runtime
CREATE b/float ALLOT ;
\ test goodies
: \S CR -1 ABORT" OK, abort at \S point, no more loaded. " ; \ ***
FCLEAR
100 SET-PRECISION \ max precision for testing
CR .( 1/7 = ) 1 S>F 7 S>F F/ F.
CR .( 1/3 = ) 1 S>F 3 S>F F/ F.
CR .( 2/3 = ) 2 S>F 3 S>F F/ F.
CR .( 355/113 = ) 355 S>F 113 S>F F/ F.
: SS fstak 120 DUMP ;
第(83)個範例，是在發展 Wina64 期間的收集，以簡潔程式算出不帶正負號雙整數的商數及餘數。
這個指令在擴充基礎 Forth 的原始系統時很有用，但因後期發展 Forth 標準的主流份子，都不熟數學，才會把所有的算術指令標準，都搞成完全不顧正負號數字的方式定義指令，這樣的水準，等同於只有台灣小學生程度的數學能力，國際上許多國家確實如此。
全世界最有名的 Forth 公司 Forth Inc. 的老闆，曾經公開在國際論壇上承認自己不懂數學，才會把當年標準中將文字轉換出數值的 NUMBER 指令規格，劣化成那樣。
因此，我自創系統時，均從最基本的 NUMBER 指令開始設計起，處理雙整數的除法時，也只好先設計無正負號的雙整數運算指令，正負號則另行設法解決，另行處理。如此一來，程式會變大、變複雜、變慢，可是碰到一群不懂數學的人領頭先落定了標準，已沒辦法，只好如此。
Win32Forth 中的整數除法，也都設計得不符合數學基本標準，道理相同，這事，前文中我已提過。
在 64 位元環境中，雙整數要用到 128 位元表示，將近 40 位數，很可怕的大。我不懂其他不用移位後相減之除法運算的程式設計方法，只懂這個自古以來就這樣設計的移位、減去方式算除法。所以，一個從 32 位元提升上來，在 64 位元環境可以照樣使用的程式，只需將原來 Do ..... Loop 前面的指標，把 64 設定，改為 128 就夠了，這就是這個範例程式的收集來源，最後一列，列有測試方法。
當然， Wina64 的原始 Forth 系統，還缺很多指令，我測試時，就逐個解決，缺什麼就補什麼，補足過的指令，都列在正式的 DU/MOD 上方，這些指令在 Win32Forth 也未必都有，若有，也要注意它們的定義是否與此處的規格相同？否則不能試用這個程式。
Win32Forth 是一個 32 位元的系統，不能直接接受 64 位元單整數的輸入，所以，您若想試這個程式，只好再把程式中的 128 改回 64 ，能處理的數字範圍較小，最大可輸入的雙整數，只能低於 20 位數。
從這些後期收集的範例，可以看得出來，我已放棄 32 位元的使用環境，但仍追回 32 位元時代的漂亮設計。 Forth 的發展歷史，有其脈絡，不是新環境內的新版都得從頭搞起，基本的東西只需略作調整就可以了。
外在的東西才有很大的變化，我卻不能在範例中談得太多。除了時效性的問題不宜談，還有許多我也不懂的外在問題不能談，許多技術都與 Forth 無關。
我收集的百例，沒辦法納入畫圖的部分，就是典型不談的困難問題。
這些事情，只能走一步算一步，碰到再說，百例只能談 Forth 份內事，也只有這樣，才能談得完百例。
我個人在國際場合中曾為了這個 NUMBER 問題，以緩和的口氣，建議在 Forth 系統中把這個已經成為問題的重要指令設計成可以向量化(vectorized)，也就是將其設計成執行內容可以重新指向，當時有過不少人附議支持，我也表示那是使用自由，不必標準化。所以，我拿到新系統，凡是不能讓我做這種規劃的系統，我就不用。我自創的系統中，都隱含式的具有這種不說的性能。
:
這個指令在擴充基礎 Forth 的原始系統時很有用，但因後期發展 Forth 標準的主流份子，都不熟數學，才會把所有的算術指令標準，都搞成完全不顧正負號數字的方式定義指令，這樣的水準，等同於只有台灣小學生程度的數學能力，國際上許多國家確實如此。
全世界最有名的 Forth 公司 Forth Inc. 的老闆，曾經公開在國際論壇上承認自己不懂數學，才會把當年標準中將文字轉換出數值的 NUMBER 指令規格，劣化成那樣。
因此，我自創系統時，均從最基本的 NUMBER 指令開始設計起，處理雙整數的除法時，也只好先設計無正負號的雙整數運算指令，正負號則另行設法解決，另行處理。如此一來，程式會變大、變複雜、變慢，可是碰到一群不懂數學的人領頭先落定了標準，已沒辦法，只好如此。
Win32Forth 中的整數除法，也都設計得不符合數學基本標準，道理相同，這事，前文中我已提過。
在 64 位元環境中，雙整數要用到 128 位元表示，將近 40 位數，很可怕的大。我不懂其他不用移位後相減之除法運算的程式設計方法，只懂這個自古以來就這樣設計的移位、減去方式算除法。所以，一個從 32 位元提升上來，在 64 位元環境可以照樣使用的程式，只需將原來 Do ..... Loop 前面的指標，把 64 設定，改為 128 就夠了，這就是這個範例程式的收集來源，最後一列，列有測試方法。
當然， Wina64 的原始 Forth 系統，還缺很多指令，我測試時，就逐個解決，缺什麼就補什麼，補足過的指令，都列在正式的 DU/MOD 上方，這些指令在 Win32Forth 也未必都有，若有，也要注意它們的定義是否與此處的規格相同？否則不能試用這個程式。
Win32Forth 是一個 32 位元的系統，不能直接接受 64 位元單整數的輸入，所以，您若想試這個程式，只好再把程式中的 128 改回 64 ，能處理的數字範圍較小，最大可輸入的雙整數，只能低於 20 位數。
從這些後期收集的範例，可以看得出來，我已放棄 32 位元的使用環境，但仍追回 32 位元時代的漂亮設計。 Forth 的發展歷史，有其脈絡，不是新環境內的新版都得從頭搞起，基本的東西只需略作調整就可以了。
外在的東西才有很大的變化，我卻不能在範例中談得太多。除了時效性的問題不宜談，還有許多我也不懂的外在問題不能談，許多技術都與 Forth 無關。
我收集的百例，沒辦法納入畫圖的部分，就是典型不談的困難問題。
這些事情，只能走一步算一步，碰到再說，百例只能談 Forth 份內事，也只有這樣，才能談得完百例。
我個人在國際場合中曾為了這個 NUMBER 問題，以緩和的口氣，建議在 Forth 系統中把這個已經成為問題的重要指令設計成可以向量化(vectorized)，也就是將其設計成執行內容可以重新指向，當時有過不少人附議支持，我也表示那是使用自由，不必標準化。所以，我拿到新系統，凡是不能讓我做這種規劃的系統，我就不用。我自創的系統中，都隱含式的具有這種不說的性能。
:
\ DUSMOD.F
\ test in wina64 ok 20170616
: 2>R POSTPONE SWAP POSTPONE >R POSTPONE >R ; IMMEDIATE
: 2R> POSTPONE R> POSTPONE R> POSTPONE SWAP ; IMMEDIATE
: 2R@ POSTPONE 2R> POSTPONE 2DUP POSTPONE 2>R ; IMMEDIATE
: 2ROT 2>R 2SWAP 2R> 2SWAP ;
: PICK 1+ CELLS DSP@ + @ ;
: D2* 2DUP D+ ;
: M+ S>D D+ ;
: DU< ROT 2DUP = IF 2DROP U< EXIT THEN 2SWAP 2DROP SWAP U< ;
: D- DNEGATE D+ ;
\ b/d = bits/double,128 for wina64
: DU/MOD ud1 ud2 -- udrem udquot )
0 0 2ROT
128 ( b/d ) 0
DO 2 PICK OVER 2>R D2* 2SWAP D2*
R> 0< 1 AND M+ 2DUP 7 PICK 7 PICK
DU< 0= R> 0< OR
IF 5 PICK 5 PICK D- 2SWAP 1 M+
ELSE 2SWAP
THEN
LOOP 2ROT 2DROP ;
\ Usage:
\ 170000000000000. 30000000000000. DU/MOD CR D. CR D.
第(84)個範例是在 Wina64 系統中測試有關『對談式輸入字串與數字』的程式設計方法。
最近的這幾個範例，都是我在 2017 年發展微軟視窗系統中 64 位元 Forth 系統時的研究成果，大部份也都是系統基礎性能的研究，如果您能取得 Wina64 ，也能測試這些程式，就可以了解我是如何走進一個新 Forth 的陌生環境，程式中都列有走過的痕跡，從很基礎的指令開始，逐個測試，直到解決構想為止。
當時的構想，是想要用 Wina64 來實現一套很基本的功能，讓資料能夠存取於檔案。我不需要把構想所需要的全部程式整套設計出來，只需像這個範例的內容一樣，測試完程式，就能知道 Wina64 能不能完成此構想了。答案是：可以。
這個主題相當於學習 Forth 時二級程度的教材，但很完整。
對檔案存取資料，此乃軟體系統一項非常基本的功能要求，不必涉及任何數學運算，相當於早期眾所週知的 Data Base 系統的要求，只存取資料。
開始測試時，需要幾個基本工具，在 Wina64 中可用 WANT 指令宣告出來。因為這個系統將延伸式指令放在另一個純文字檔中，作為輔助資源，您不用時，可以不必理會它的存在。例如，我對該系統提供的反向語法式組合語言程式寫法不滿意，我就絕對不用 WANT 來叫用它。這個範例需要測試能否把檔案開啟在系統之外？於是，我叫用了 ALLOCATE ，它涉及作業系統庫存的功能程式，測試後顯示功能正常。
資料的存取只有兩種，一是文字，另一是數字，純文字資料檔案不研究格式化所需要的控制碼，所以，也不必研究。
資料的存取，需要用到螢幕上的直接對談操作，在 Wina64 中許多這種指令都被當作延伸性指令另存於輔助檔案中，例如： WORD , >IN , QUERY , /STRING 等指令，為了測試方便，我把他們以帶有源碼的方式，提存到這個測試檔案中來了，都列在這個範例內。處理將輸入字串轉換成雙整數所需要的 DNUMBER ，我也加列在此範例中，以便可以直接使用。 File I/O 也從我個人的資源中 copy 至此，只有一個 R/W 的設定對不對需要注意。
測試簡例只需設計如何對談式的接受輸入字串 INPUT$ ，以及設計如何接受輸入數字 INPUT# 。
接受的字串，是以壓下 Enter 鍵作為分隔界線，所以字串中可以帶有空格。
接受的數字，是以雙整數的規格作為基準，所以，單、雙整數都能處理，也就是帶不帶小數點的輸入數字都能接受。
簡單的儲存位置，只需宣告出字串與變數的資料格式，便能進行。總結的 TEST , TEST1 兩個總程式，可以與您直接對談，然後將剛剛輸入之結果正確的顯示出來，就完成了測試。
至於在 Data Base 系統中，如何將文字與數字存取於檔案的設計，此範例中沒有做。要做，也不難，我設計過，觀念上背下來：檔中有錄，錄中有欄，欄中有數字或文字，這樣就夠了。只要開啟得了檔案，就能取得起始位址，每筆記錄需要多少記憶體之量是固定的，想存取那一筆資料就能換算出來。每筆記錄中的欄位長度也是固定的，記憶體位址當然也就能被換算出來。欄中資料只有兩類，要嘛是文字，要嘛就是數字，不可以是其他東西。這樣，一份資料就都能被換算出可以存取的位址了。如果有這一段文字內的觀念，搞 Data Base 就夠了，這就是往昔 COBOL 程式語言的基本觀念，因為設計資料處理系統所需要的技術知識太簡單了，單篇文章就能簡談完畢，所以我不搞，我只喜歡搞比較有技術性的數學計算。
當然，在資料處理系統的發展歷史中，後來也發展出許多字串處理所需要的特殊指令，也發展出讓搜索比對速度能夠變快的原理及方法。甚至於增添前處理技術，透過加添一層所謂的關鍵字索引(key words index)技術，於存入資料時，就先行分類規劃，於資料被取用時，就能透過已分類的好處而加速搜索獲得。還有，採用類似超級電腦多 CPU 平行處理的能力，分擔網上系統的運作工作，讓網搜速度飛快實現，等等等。這些方法與技術，就是當今網上海量數據的處理方法，我用 4 個 CPU 模擬實做過，也都懂得它們的設計方法，所以知道網上大數據公司不給你使用『關鍵字索引資料庫』的使用權時，您設計的搜索引擎再快也沒有用的道理，個人就大可不必浪費時間搞這種發展了。
這些東西，我沒有興趣去深入研究與探討，只是懂得而已。畢竟，我是學理工的，不是學法商的。中國大陸有比我更高明的許多後起之秀，都知道這些比較容易學得會的 Data Base 基本運作原理，因此，中國早就有了他們自己的網上資料系統，是華人之光。台灣沒有，搞過的人，都去替美國佬、洋鬼子工作，只上班領薪水。
至於數學計算技術，中國大陸還沒有能像我這樣、能自建數學運算系統的人，全世界也沒有幾個人能搞得出像我這樣的設計，因為，需要懂得的知識與技術比較多、比較難。
:
最近的這幾個範例，都是我在 2017 年發展微軟視窗系統中 64 位元 Forth 系統時的研究成果，大部份也都是系統基礎性能的研究，如果您能取得 Wina64 ，也能測試這些程式，就可以了解我是如何走進一個新 Forth 的陌生環境，程式中都列有走過的痕跡，從很基礎的指令開始，逐個測試，直到解決構想為止。
當時的構想，是想要用 Wina64 來實現一套很基本的功能，讓資料能夠存取於檔案。我不需要把構想所需要的全部程式整套設計出來，只需像這個範例的內容一樣，測試完程式，就能知道 Wina64 能不能完成此構想了。答案是：可以。
這個主題相當於學習 Forth 時二級程度的教材，但很完整。
對檔案存取資料，此乃軟體系統一項非常基本的功能要求，不必涉及任何數學運算，相當於早期眾所週知的 Data Base 系統的要求，只存取資料。
開始測試時，需要幾個基本工具，在 Wina64 中可用 WANT 指令宣告出來。因為這個系統將延伸式指令放在另一個純文字檔中，作為輔助資源，您不用時，可以不必理會它的存在。例如，我對該系統提供的反向語法式組合語言程式寫法不滿意，我就絕對不用 WANT 來叫用它。這個範例需要測試能否把檔案開啟在系統之外？於是，我叫用了 ALLOCATE ，它涉及作業系統庫存的功能程式，測試後顯示功能正常。
資料的存取只有兩種，一是文字，另一是數字，純文字資料檔案不研究格式化所需要的控制碼，所以，也不必研究。
資料的存取，需要用到螢幕上的直接對談操作，在 Wina64 中許多這種指令都被當作延伸性指令另存於輔助檔案中，例如： WORD , >IN , QUERY , /STRING 等指令，為了測試方便，我把他們以帶有源碼的方式，提存到這個測試檔案中來了，都列在這個範例內。處理將輸入字串轉換成雙整數所需要的 DNUMBER ，我也加列在此範例中，以便可以直接使用。 File I/O 也從我個人的資源中 copy 至此，只有一個 R/W 的設定對不對需要注意。
測試簡例只需設計如何對談式的接受輸入字串 INPUT$ ，以及設計如何接受輸入數字 INPUT# 。
接受的字串，是以壓下 Enter 鍵作為分隔界線，所以字串中可以帶有空格。
接受的數字，是以雙整數的規格作為基準，所以，單、雙整數都能處理，也就是帶不帶小數點的輸入數字都能接受。
簡單的儲存位置，只需宣告出字串與變數的資料格式，便能進行。總結的 TEST , TEST1 兩個總程式，可以與您直接對談，然後將剛剛輸入之結果正確的顯示出來，就完成了測試。
至於在 Data Base 系統中，如何將文字與數字存取於檔案的設計，此範例中沒有做。要做，也不難，我設計過，觀念上背下來：檔中有錄，錄中有欄，欄中有數字或文字，這樣就夠了。只要開啟得了檔案，就能取得起始位址，每筆記錄需要多少記憶體之量是固定的，想存取那一筆資料就能換算出來。每筆記錄中的欄位長度也是固定的，記憶體位址當然也就能被換算出來。欄中資料只有兩類，要嘛是文字，要嘛就是數字，不可以是其他東西。這樣，一份資料就都能被換算出可以存取的位址了。如果有這一段文字內的觀念，搞 Data Base 就夠了，這就是往昔 COBOL 程式語言的基本觀念，因為設計資料處理系統所需要的技術知識太簡單了，單篇文章就能簡談完畢，所以我不搞，我只喜歡搞比較有技術性的數學計算。
當然，在資料處理系統的發展歷史中，後來也發展出許多字串處理所需要的特殊指令，也發展出讓搜索比對速度能夠變快的原理及方法。甚至於增添前處理技術，透過加添一層所謂的關鍵字索引(key words index)技術，於存入資料時，就先行分類規劃，於資料被取用時，就能透過已分類的好處而加速搜索獲得。還有，採用類似超級電腦多 CPU 平行處理的能力，分擔網上系統的運作工作，讓網搜速度飛快實現，等等等。這些方法與技術，就是當今網上海量數據的處理方法，我用 4 個 CPU 模擬實做過，也都懂得它們的設計方法，所以知道網上大數據公司不給你使用『關鍵字索引資料庫』的使用權時，您設計的搜索引擎再快也沒有用的道理，個人就大可不必浪費時間搞這種發展了。
這些東西，我沒有興趣去深入研究與探討，只是懂得而已。畢竟，我是學理工的，不是學法商的。中國大陸有比我更高明的許多後起之秀，都知道這些比較容易學得會的 Data Base 基本運作原理，因此，中國早就有了他們自己的網上資料系統，是華人之光。台灣沒有，搞過的人，都去替美國佬、洋鬼子工作，只上班領薪水。
至於數學計算技術，中國大陸還沒有能像我這樣、能自建數學運算系統的人，全世界也沒有幾個人能搞得出像我這樣的設計，因為，需要懂得的知識與技術比較多、比較難。
:
\ (84)STRING.F
\ in wina64 test ok 20170616
1 LOAD
WANT DUMP
WANT ALLOCATE
WANT SEE
: WORD ( c -- addr )
DUP BL = IF DROP NAME ELSE >R \ line933
BEGIN PP@@ R@ = WHILE DROP REPEAT DROP -1 PP +!
R> PARSE THEN HERE 34 BLANK HERE
2DUP C! 1+ SWAP CMOVE \ $!-BD
HERE ;
\ only PP able to be used in file. >IN can not to be used in file.
\ QUERY here can be used in command console so use >IN?
\ ACCEPT ( addr count -- n )
: >IN ( -- )
PP ;
: QUERY ( -- )
TIB @ DUP 80 ACCEPT SET-SRC 0 (>IN) ! ;
: /STRING ( addr1 u1 n -- addr2 u2 )
>R R@ - SWAP R> + SWAP ;
0 CONSTANT FALSE
-1 CONSTANT TRUE
: D>S DROP ;
: DNUMBER ( addr count -- d +f | -f)
0.
2SWAP OVER C@ [CHAR] - = DUP >R
IF 1 /STRING THEN
>NUMBER
SWAP DROP
IF 2DROP R> DROP FALSE
ELSE R>
IF DNEGATE THEN
TRUE
THEN
;
: STRING
CREATE ALLOT ( n -- )
DOES> ( -- addr )
;
256 STRING AAA
256 STRING BBB
VARIABLE CCC
: INPUT$ ( -- addr count )
QUERY 13 WORD COUNT ;
: INPUT# ( -- n )
QUERY BL WORD COUNT DNUMBER
IF D>S ELSE ABORT" Warning! Input unknown?" THEN ;
: TEST
." Enter your name: " INPUT$ CR
." Hello there, " TYPE CR
." Enter a number: " INPUT# CR
." Your number is " . CR
;
: TEST1
." ENTER STRING AAA: " INPUT$ AAA $!
." ENTER STRING BBB: " INPUT$ BBB $!
." ENTER A NUMBER : " INPUT# CCC !
CR AAA $@ TYPE
CR BBB $@ TYPE
CR CCC @ . CR
." ENTER APPENDED STRING : " INPUT$ AAA $+!
CR AAA $@ TYPE
;
\ 4. FILE I/O
\ 100 ALLOCATE DROP CONSTANT DDD
\ AAA $@ DDD SWAP MOVE
\ DDD 40 DUMP
\ This file operation program works in Lina64 under CentOS7
\ Author: Ching Tang Tseng
\ Date : 20160310, Hamilton, New Zealand
\ WANT ALLOCATE
\ -rw0rw0rw0 = 110110110b = 438d : all are R/W enable
438 CONSTANT R/W
VARIABLE FileID
VARIABLE Fptr
VARIABLE Frem
VARIABLE Flen
VARIABLE Fsize 1024000 Fsize !
\ (1)floating Fadr
\ : Fadr PAD 4096 + ;
\ (2)allocate Fadr ???
Fsize @ ALLOCATE DROP CONSTANT Fadr
\ (3)fixed Fadr: 1 MB below EM
\ EM HERE - . --> get 33425420 --> 33 MB free spaces
\ : Fadr EM 1024000 - ;
: SetUpFptrFrem ( -- )
Fadr Fptr !
Flen @ Frem ! ;
: (FILE.) ( -- addr len )
Fadr Flen @ ;
: FileType ( -- )
CR (FILE.) TYPE ;
: FileDump ( -- )
CR (FILE.) DUMP ;
\ Beware! only a R/W attributed file can be manipulated
\ S" Filename.f" GetFile = "Filename.f" GetFile
: GetFile ( addr len -- )
Fadr Fsize @ 0 FILL
R/W OPEN-FILE
IF CR ABORT" OPEN-FILE error?" THEN FileID !
CR ." File ID is : " FileID @ .
Fadr Fsize @ FileID @ READ-FILE
IF CR ABORT" READ-FILE error?" THEN
DUP Flen !
CR . ." Bytes has been read!"
FileID @ CLOSE-FILE
IF CR ABORT" CLOSE-FILE error!" THEN
SetUpFptrFrem ;
\ use PAD area create all blanks
: NewFile ( addr len n -- )
Flen ! PAD Flen @ 32 FILL
R/W CREATE-FILE
IF CR ABORT" CREATE-FILE error!" THEN FileID !
PAD Flen @ FileID @ WRITE-FILE
IF CR ABORT" WRITE-FILE error!" THEN
CR Flen @ . ." Bytes has been written!"
FileID @ CLOSE-FILE
IF CR ABORT" CLOSE-FILE error!" THEN
SetUpFptrFrem ;
\ Beware! Flen must be set, before you WriteFile
: SaveFile ( addr len -- )
R/W CREATE-FILE
IF CR ABORT" CREATE-FILE error!" THEN FileID !
CR ." FileID is: " FileID @ .
Fadr Flen @ FileID @ WRITE-FILE
IF CR ABORT" WRITE-FILE error!" THEN
CR Flen @ . ." Bytes has been written!"
FileID @ CLOSE-FILE
IF CR ABORT" CLOSE-FILE error!" THEN ;
\ for simple testing usage:
\ : SendText>F ( adr n -- )
\ DUP Flen ! Fadr SWAP MOVE ;
\ S" This is a simple test." SendText>F
\ then, use FileType or use FileDump to check
\ Frem, Fptr are to be used for other testing.
第(85)個範例，是一個利用純文字視窗以文字格式繪製 Mandelbrot 圖形的展示程式。
若要討論操控文字輸出技術的發展極致，就屬這種範例程式了。百例已經進展到末期，我憶及了應該控存這種技術，就納進了這個範例。
相似的技術，也有單憑文字視窗來繪製能有動態閃爍彩色文字聖誕樹的繪圖，也有利用垂直滾動視窗功能顯示全畫面以文字打點式的函數繪圖程式，甚至於設計迷宮式的電玩或俄羅斯積木，都是類似的典範，在 Win32Forth 系統的 Demo 範例中就也提供，大家可以自己試跑看看。
從這個繪製 Mandelbrot 圖形的程式可以看得出來，想繪製圖形，首先就得搞清楚它的數學意義，光看式子也未必能真懂，繪製出圖後，您才能真懂。
Mandelbrot 繪圖法則，在我的個人網頁 20120201 網文： Advanced BASIC in Charming FORTH 中有，我重新節錄要點於此，免得您還得跳看網頁才能找得到資料，該文中是這樣說的：
**************************
簡而言之，Mandelbrot 繪圖，就是在一個指定的平面空間內，根據下列複數運算的式子，進行遞迴循環計算：
Z ( n+1 ) = Z ( 0 ) + Z ( n ) * Z ( n )
Z(0) 按照與座標相關的固定規則，賦予起始值後，開始計算。當複數 Z( n+1 ) 之絕對值，大於某一指定數值時，便取用已經遞迴循環的次數，作為選擇顏色的代表值，然後彩繪出一點，如此繪出的全圖，就稱為 Mandelbrot 圖形。
***************************
把上訴文字中的『作為選擇顏色的代表值，然後彩繪出一點』改成『作為選擇印出文字的字碼值，然後印出一個字元』，就是這個範例的繪圖原理了。
在我的網文中所採用的程式是 BASIC 式的語法寫成的，很容易看懂。這三個範例則都是採用純 Forth 語法寫成的，比較不容易看懂。我為三套不同的 Forth 系統改出了各自可以執行的程式，也顯現出 Forth 各種系統的規格無法統一的現象。這種情況，是 Forth 與生俱來的問題，會令初學者非常困擾，我在長期推廣過 Forth 後，已深知此問題，不再強調，只能任其自由發展，真正有心拿 Forth 做出產品的人，是不會在乎這種困擾的，無心者，很快就會被淘汰掉而離開 Forth 的世界，事實就是這樣。
Forth 不是無用的東西，光看這百例，您就可以知道其用途無限，好像什麼事都能幹。我若有心，舉千例來討論，也不是問題，以數學歸納法證明這種事情，可以舉得出千例，就是當然的結果。
:
若要討論操控文字輸出技術的發展極致，就屬這種範例程式了。百例已經進展到末期，我憶及了應該控存這種技術，就納進了這個範例。
相似的技術，也有單憑文字視窗來繪製能有動態閃爍彩色文字聖誕樹的繪圖，也有利用垂直滾動視窗功能顯示全畫面以文字打點式的函數繪圖程式，甚至於設計迷宮式的電玩或俄羅斯積木，都是類似的典範，在 Win32Forth 系統的 Demo 範例中就也提供，大家可以自己試跑看看。
從這個繪製 Mandelbrot 圖形的程式可以看得出來，想繪製圖形，首先就得搞清楚它的數學意義，光看式子也未必能真懂，繪製出圖後，您才能真懂。
Mandelbrot 繪圖法則，在我的個人網頁 20120201 網文： Advanced BASIC in Charming FORTH 中有，我重新節錄要點於此，免得您還得跳看網頁才能找得到資料，該文中是這樣說的：
**************************
簡而言之，Mandelbrot 繪圖，就是在一個指定的平面空間內，根據下列複數運算的式子，進行遞迴循環計算：
Z ( n+1 ) = Z ( 0 ) + Z ( n ) * Z ( n )
Z(0) 按照與座標相關的固定規則，賦予起始值後，開始計算。當複數 Z( n+1 ) 之絕對值，大於某一指定數值時，便取用已經遞迴循環的次數，作為選擇顏色的代表值，然後彩繪出一點，如此繪出的全圖，就稱為 Mandelbrot 圖形。
***************************
把上訴文字中的『作為選擇顏色的代表值，然後彩繪出一點』改成『作為選擇印出文字的字碼值，然後印出一個字元』，就是這個範例的繪圖原理了。
在我的網文中所採用的程式是 BASIC 式的語法寫成的，很容易看懂。這三個範例則都是採用純 Forth 語法寫成的，比較不容易看懂。我為三套不同的 Forth 系統改出了各自可以執行的程式，也顯現出 Forth 各種系統的規格無法統一的現象。這種情況，是 Forth 與生俱來的問題，會令初學者非常困擾，我在長期推廣過 Forth 後，已深知此問題，不再強調，只能任其自由發展，真正有心拿 Forth 做出產品的人，是不會在乎這種困擾的，無心者，很快就會被淘汰掉而離開 Forth 的世界，事實就是這樣。
Forth 不是無用的東西，光看這百例，您就可以知道其用途無限，好像什麼事都能幹。我若有心，舉千例來討論，也不是問題，以數學歸納法證明這種事情，可以舉得出千例，就是當然的結果。
:
\ (85-1)Win32Forth version fvariable ci fvariable c fvariable zi fvariable z : >2? z f@ fdup f* zi f@ fdup f* f+ 4.0e0 f> ; : nextr z f@ fdup f* zi f@ fdup f* f- c f@ f+ ; : nexti z f@ zi f@ f* 2.0e0 f* ci f@ f+ ; : pixel c f! ci f! 0.0e0 z f! 0.0e0 zi f! 150 50 do nextr nexti zi f! z f! >2? if i unloop exit then loop bl ; : left->right -1.5e0 80 0 do fover fover pixel emit 0.026e0 f+ loop fdrop ; : top->bottom -1.0e0 40 0 do left->right cr 0.05e0 f+ loop fdrop ; : main cr top->bottom ; page main \ (85-2)Wina32 ABC Forth512 version fvariable ci fvariable c fvariable zi fvariable z : >2? z f@ fdup f* zi f@ fdup f* f+ 4.0 e 0 f> ; : nextr z f@ fdup f* zi f@ fdup f* f- c f@ f+ ; : nexti z f@ zi f@ f* 2.0 e 0 f* ci f@ f+ ; : pixel c f! ci f! 0.0 e 0 z f! 0.0 e 0 zi f! 150 50 do nextr nexti zi f! z f! >2? if i unloop exit then loop bl ; : left->right -1.5 e 0 79 0 do fover fover pixel emit 0.026 e 0 f+ loop fdrop ; \ 80 ->79 : top->bottom -1.0 e 0 40 0 do left->right cr 0.05 e 0 f+ loop fdrop ; top->bottom \ all ( 0 e 0 ) -> ( 0.0 e 0 ) \ (85-3)Forth64 version fvariable ci fvariable c fvariable zi fvariable z : >2? z f@ fdup f* zi f@ fdup f* f+ 4.0e f> ; : nextr z f@ fdup f* zi f@ fdup f* f- c f@ f+ ; : nexti z f@ zi f@ f* 2.0e f* ci f@ f+ ; : pixel c f! ci f! 0e z f! 0e zi f! 150 50 do nextr nexti zi f! z f! >2? if i unloop exit then loop bl ; : left->right -1.5e 80 0 do fover fover pixel emit 0.026e f+ loop fdrop ; : main ( top->bottom ) cr -1e 40 0 do left->right cr 0.05e f+ loop fdrop ;
訂閱：
張貼留言 (Atom)
沒有留言:
張貼留言