home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MAGAZINE / DDJMAG / DDJ8610.ZIP / HAM.OCT < prev    next >
Encoding:
Text File  |  1986-10-31  |  3.3 KB  |  124 lines
  1.   0 CONSTANT US>D  ( convert unsigned single to double )
  2.  
  3. : % ( n1 n2 - ) ( calculates and prints percentage to tenths  )
  4.      35 10 GOTOXY                 ( position cursor ) 
  5.      10000 SWAP */ 5 + 10 /       ( figure percentage and round )
  6.      US>D <# # ASCII . HOLD #S #> ( format number as string )
  7.      TYPE ASCII % EMIT ;          ( type it with % )
  8.  
  9.   ( Note:  Cursor-positioning is vendor dependent.  )
  10.   ( ASCII is immediate.  It puts on the stack the   )
  11.   ( ASCII value of the character that follows it.   )
  12.  
  13.          Listing 1:  Calculating and printing percentage
  14.  
  15.  
  16.  
  17. : .0%  ( n1 n2 - n3 ) ( n3 = %age n1 is of n2, rounded to tenths )
  18.     10000 SWAP */ 5 + 10 / ;
  19.  
  20. : TENTHS ( n - adr cnt ) US>D <# # ASCII . HOLD #S #> ;
  21.  
  22. : %.  ( n1 n2 - )  .0% TENTHS TYPE ASCII % EMIT ;
  23.  
  24. : %.R ( # n1 n2 - ) ( # is width of field; display flush right )
  25.      %.0 TENTHS ROT OVER - SPACES TYPE ASCII % EMIT ; 
  26.  
  27.                Listing 2:  A more general approach
  28.  
  29.  
  30.  
  31.    440 CONSTANT A   ( note defined by its frequency )
  32.  
  33. : OCTAVE ( creates a note of double the frequency )
  34.          2*  CREATE ,
  35.          DOES> ( <adr> -- freq )  @ ;
  36.  
  37.    A OCTAVE A'      ( defines the frequency of the octave )
  38.  
  39. : OCTAVE 2* CONSTANT ;    ( alternate definition )
  40.  
  41.  
  42.           Listing 3:  Using CONSTANT in a defining word 
  43.  
  44.  
  45.  
  46.     CREATE OPTIONS  ] >PRINTER  >DISK  >SCREEN  >DOS [
  47.  
  48. : DO-OPTION ( n - )  2* OPTIONS + @ EXECUTE ;
  49.  
  50. 0 DO-OPTION  ( to printer )
  51. 1 DO-OPTION  ( to disk )
  52. 3 DO-OPTION  ( to DOS )
  53. 4 DO-OPTION  ( unpredictable results )
  54.  
  55.           Listing 4:  Execution array, first definition
  56.  
  57.  
  58.  
  59.    0 CONSTANT F    -1 CONSTANT T
  60.  
  61. :  VECTOR:  : ( compile operators )
  62.             DOES> SWAP 2* + @ EXECUTE ;
  63.  
  64.  VECTOR: OPTION   >PRINTER >DISK >SCREEN >DOS ;
  65.  
  66.   0 OPTION  ( to printer )
  67.   2 OPTION  ( to screen ) 
  68.  
  69.         Listing 5:  A defining word for execution vectors
  70.  
  71.  
  72.  
  73.   CREATE BITS  1 C, 2 C, 4 C, 8 C, 16 C, 32 C, 64 C, 128 C,
  74.  
  75. : S>B  ( ? - f ) 0<> ; ( forces to a boolean:  -1 or 0 )
  76. : MASK ( bit# - mask )  BITS + C@ ;
  77.  
  78. : AIM   ( # a - bit# a ) SWAP 8 /MOD ROT + ;
  79.  
  80. : +BIT ( bit# a - ) AIM SWAP MASK OVER C@  OR SWAP C! ;
  81. : -BIT ( bit# a - ) AIM SWAP MASK NOT OVER C@ AND SWAP C! ;
  82. : @BIT ( bit# a - f ) AIM C@ SWAP MASK AND S>B ;
  83. : ~BIT ( bit# a - ) AIM 2DUP @BIT IF -BIT ELSE +BIT THEN ;
  84.  
  85.                     Listing 6:  Bit twiddlers
  86.  
  87.  
  88.  
  89.   CREATE TEST 16 ALLOT
  90.  
  91. : SETflags  TEST 16 ERASE
  92.    ASCII ! TEST +BIT
  93.    ASCII & 1+ ASCII # DO I TEST +BIT LOOP
  94.    ASCII ( TEST +BIT   ASCII ) TEST +BIT   ASCII ' TEST +BIT
  95.    ASCII ` TEST +BIT   ASCII _ TEST +BIT   ASCII - TEST +BIT
  96.    ASCII { TEST +BIT   ASCII } TEST +BIT 
  97.    ASCII Z 1+ ASCII @ DO I TEST +BIT LOOP 
  98.    ASCII 9 1+ ASCII 0 DO I TEST +BIT LOOP ;
  99.  
  100. : READOUT 128 0 DO I TEST @BIT IF I EMIT THEN LOOP SPACE ;
  101.  
  102. : READ     16 0 DO TEST I + @ . 2 +LOOP ;
  103.  
  104.   SETflags ok
  105.  
  106.   READOUT !#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ_`{} ok
  107.  
  108.   READ 0 0 9210 1023 -1 -30721 1 10240 ok
  109.   
  110.          Listing 7:  Bits for valid filename characters
  111.  
  112.  
  113.  
  114.  
  115.   CREATE LEGAL 0 , 0 , 9210 , 1023 , -1 , -30721 , 1 , 10240 ,
  116.  
  117.   ( Bit set in LEGAL only if character is legal in filename )
  118.   ( Map is by ASCII value of the character. )
  119.  
  120. : OK-CHAR? ( ASCII-char -- f ; T = valid character for filename )
  121.      LEGAL @BIT ; 
  122.  
  123.                  Listing 8:  Checking characters
  124.