dsforth/math_misc.zas

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; misc math words
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4
   5 $FORTH_CODE_WORD 1+
   6 ;; k8
   7 ;; ( n -- n+1 )
   8   pop   hl
   9   inc   hl
  10   jp    i_pushhl
  11 $FORTH_END_CODE_WORD 1+
  12
  13 $FORTH_CODE_WORD 2+
  14 ;; k8
  15 ;; ( n -- n+2 )
  16   pop   hl
  17   inc   hl
  18   inc   hl
  19   jp    i_pushhl
  20 $FORTH_END_CODE_WORD 2+
  21
  22 $FORTH_CODE_WORD 4+
  23 ;; k8
  24 ;; ( n -- n+4 )
  25   pop   hl
  26   inc   hl
  27   inc   hl
  28   inc   hl
  29   inc   hl
  30   jp    i_pushhl
  31 $FORTH_END_CODE_WORD 4+
  32
  33 $FORTH_CODE_WORD 1-
  34 ;; k8
  35 ;; ( n -- n-1 )
  36   pop   hl
  37   dec   hl
  38   jp    i_pushhl
  39 $FORTH_END_CODE_WORD 1-
  40
  41 $FORTH_CODE_WORD 2-
  42 ;; k8
  43 ;; ( n -- n-2 )
  44   pop   hl
  45   dec   hl
  46   dec   hl
  47   jp    i_pushhl
  48 $FORTH_END_CODE_WORD 2-
  49
  50 $FORTH_CODE_WORD 4-
  51 ;; k8
  52 ;; ( n -- n-4 )
  53   pop   hl
  54   dec   hl
  55   dec   hl
  56   dec   hl
  57   dec   hl
  58   jp    i_pushhl
  59 $FORTH_END_CODE_WORD 4-
  60
  61 $FORTH_CODE_WORD 256U*
  62 ;; k8
  63 ;; ( n -- n*256u )
  64   pop   hl
  65   ld    h,l
  66   ld    l,0
  67   jp    i_pushhl
  68 $FORTH_END_CODE_WORD 256U*
  69
  70 $FORTH_CODE_WORD 256U/
  71 ;; k8
  72 ;; ( n -- n/256u )
  73   pop   hl
  74   ld    l,h
  75   ld    h,0
  76   jp    i_pushhl
  77 $FORTH_END_CODE_WORD 256U/
  78
  79 $FORTH_CODE_WORD 2U/
  80 ;; k8
  81 ;; ( n -- n/2 )
  82   pop   hl
  83   or    a
  84   rr    h
  85   rr    l
  86   jp    i_pushhl
  87 $FORTH_END_CODE_WORD 2U/
  88
  89 $FORTH_CODE_WORD 2U*
  90 ;; k8
  91 ;; ( n -- n*2 )
  92   pop   hl
  93   or    a
  94   rl    l
  95   rl    h
  96   jp    i_pushhl
  97 $FORTH_END_CODE_WORD 2U*
  98
  99 $FORTH_CODE_WORD 2UMOD
 100 ;; k8
 101 ;; ( n -- n%2 )
 102   pop   hl
 103   ld    a,l
 104   and   #01
 105   ld    l,a
 106   ld    h,0
 107   jp    i_pushhl
 108 $FORTH_END_CODE_WORD 2UMOD
 109
 110 $FORTH_CODE_WORD 256UMOD
 111 ;; k8
 112 ;; ( n -- n%256u )
 113   pop   hl
 114   ld    h,0
 115   jp    i_pushhl
 116 $FORTH_END_CODE_WORD 256UMOD
 117
 118 $FORTH_CODE_WORD SHL
 119 ;; k8
 120 ;; ( n count -- n<<count )
 121   pop   de
 122   pop   hl
 123   ld    a,d
 124   or    a
 125   jr    nz,shl_zero_res
 126   ld    a,e
 127   or    a
 128   jp    z,i_pushhl
 129   cp    16
 130   jr    nc,shl_zero_res
 131 shl_loop:
 132   or    a
 133   rl    l
 134   rl    h
 135   dec   e
 136   jr    nz,shl_loop
 137   jp    i_pushhl
 138 shl_zero_res:
 139   ld    hl,0
 140   jp    i_pushhl
 141 $FORTH_END_CODE_WORD SHL
 142
 143 $FORTH_CODE_WORD SHR
 144 ;; k8
 145 ;; ( n count -- n>>count )
 146   pop   de
 147   pop   hl
 148   ld    a,d
 149   or    a
 150   jr    nz,shl_zero_res
 151   ld    a,e
 152   or    a
 153   jp    z,i_pushhl
 154   cp    16
 155   jr    nc,shl_zero_res
 156 shr_loop:
 157   or    a
 158   rr    h
 159   rr    l
 160   dec   e
 161   jr    nz,shr_loop
 162   jp    i_pushhl
 163 $FORTH_END_CODE_WORD SHR
 164
 165 $FORTH_CODE_WORD SAR
 166 ;; k8
 167 ;; ( n count -- n>>count )
 168   pop   de
 169   pop   hl
 170   ld    a,d
 171   or    a
 172   jr    nz,sal_too_much
 173   ld    a,e
 174   or    a
 175   jp    z,i_pushhl
 176   cp    16
 177   jr    nc,sal_too_much
 178   ld    a,h
 179   ld    d,0x80
 180 sar_loop:
 181   cp    d
 182   ccf
 183   rr    h
 184   rr    l
 185   dec   e
 186   jr    nz,sar_loop
 187   jp    i_pushhl
 188 sal_too_much:
 189   bit   7,h
 190   ld    hl,0
 191   jp    z,i_pushhl
 192   dec   hl
 193   jp    i_pushhl
 194 $FORTH_END_CODE_WORD SAR
 195
 196
 197 $FORTH_CODE_WORD ISGN
 198 ;; k8
 199 ;; ( 16 -- -1 or 0 or 1 )
 200   pop   hl
 201   bit   7,h
 202   jr    nz,isgn_negative
 203   ld    a,h
 204   or    l
 205   jp    z,i_pushhl  ;; zero
 206   ;; positive
 207   ld    hl,1
 208   jp    i_pushhl
 209 isgn_negative:
 210   ld    hl,0xffff
 211   jp    i_pushhl
 212 $FORTH_END_CODE_WORD ISGN
 213
 214
 215 $FORTH_CODE_WORD USQRT
 216 ;; k8
 217 ;; ( 16 -- 8 )
 218   pop   hl
 219   push  bc
 220   call  sqrt16_hl
 221   pop   bc
 222   ld    l,a
 223   ld    h,0
 224   jp    i_pushhl
 225 $FORTH_END_CODE_WORD USQRT
 226
 227 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 228 ;; fast 16-bit integer square root
 229 ;; 92 bytes, 344-379 cycles (average 362)
 230 ;; v2 - 3 t-state optimization spotted by Russ McNulty
 231 ;; http://www.retroprogramming.com/2017/07/a-fast-z80-integer-square-root.html
 232 ;; k8: NOT TESTED YET!
 233 ;;
 234 ;; IN:
 235 ;;   HL: number
 236 ;; OUT:
 237 ;;   A: square root
 238 ;;   HL: dead
 239 ;;   DE: dead
 240 ;;   F: dead
 241 sqrt16_hl:
 242   ld    a,h
 243   ld    de,0B0C0h
 244   add   a,e
 245   jr    c,.sq7
 246   ld    a,h
 247   ld    d,0F0h
 248 .sq7:
 249 ; ----------
 250   add   a,d
 251   jr    nc,.sq6
 252   res   5,d
 253   db    254
 254 .sq6:
 255   sub   d
 256   sra   d
 257 ; ----------
 258   set   2,d
 259   add   a,d
 260   jr    nc,.sq5
 261   res   3,d
 262   db    254
 263 .sq5:
 264   sub   d
 265   sra   d
 266 ; ----------
 267   inc   d
 268   add   a,d
 269   jr    nc,.sq4
 270   res   1,d
 271   db    254
 272 .sq4:
 273   sub   d
 274   sra   d
 275   ld    h,a
 276 ; ----------
 277   add   hl,de
 278   jr    nc,.sq3
 279   ld    e,040h
 280   db    210
 281 .sq3:
 282   sbc   hl,de
 283   sra   d
 284   ld    a,e
 285   rra
 286 ; ----------
 287   or    010h
 288   ld    e,a
 289   add   hl,de
 290   jr    nc,.sq2
 291   and   0DFh
 292   db    218
 293 .sq2:
 294   sbc   hl,de
 295   sra   d
 296   rra
 297 ; ----------
 298   or    04h
 299   ld    e,a
 300   add   hl,de
 301   jr    nc,.sq1
 302   and   0F7h
 303   db    218
 304 .sq1:
 305   sbc   hl,de
 306   sra   d
 307   rra
 308 ; ----------
 309   inc   a
 310   ld    e,a
 311   add   hl,de
 312   jr    nc,.sq0
 313   and   0FDh
 314 .sq0:
 315   sra   d
 316   rra
 317   cpl
 318   ret
 319
 320
 321 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 322 ;; generate random number
 323 ;; period of 2^32-1, and passes most of the diehard tests
 324 ;; this is the preferred PRNG, it is fast, small and good
 325 ;;
 326 ;; IN:
 327 ;;   rndSeed: 4 bytes of shit
 328 ;; OUT:
 329 ;;   HL: 16-bit random
 330 ;;   DE: dead
 331 ;;   AF: dead
 332 ;; WARNING:
 333 ;;  be careful to not have all zeroes in rndSeed!
 334 ;;
 335 ;;  taken from http://www.worldofspectrum.org/forums/showthread.php?t=23070
 336 ;;  original code by Patrik Rak (2012, based on Einar Saukas version)
 337 random_marsaglia:
 338   ld    hl,#a280       ; yw -> zt
 339 rndSeed0 equ $-2
 340   ld    de,#c0de       ; xz -> yw
 341 rndSeed1 equ $-2
 342   ld    (rndSeed1),hl  ; x = y, z = w
 343   ld    a,l            ; w = w^(w<<3)
 344   add   a,a
 345   add   a,a
 346   add   a,a
 347   xor   l
 348   ld    l,a
 349   ld    a,d            ; t = x^(x<<1)
 350   add   a,a
 351   xor   d
 352   ld    h,a
 353   rra                  ; t = t^(t>>1)^w
 354   xor   h
 355   xor   l
 356   ld    h,e            ; y = z
 357   ld    l,a            ; w = t
 358   ld    (rndSeed0),hl
 359   ret
 360
 361
 362 $FORTH_CODE_WORD D-RANDSEED@
 363 ;; k8 -- set 16-bit random seed
 364 ;; ( -- lo hi )
 365   ld    hl,(rndSeed0)
 366   ld    de,(rndSeed1)
 367   jp    i_pushde
 368 $FORTH_END_CODE_WORD D-RANDSEED@
 369
 370 $FORTH_CODE_WORD RANDSEED!
 371 ;; k8 -- set 16-bit random seed
 372 ;; ( n -- )
 373   pop   hl
 374   ld    (rndSeed0),hl
 375   ld    hl,#c0de
 376   ld    (rndSeed1),hl
 377   jp    i_next
 378 $FORTH_END_CODE_WORD RANDSEED!
 379
 380 $FORTH_CODE_WORD D-RANDSEED!
 381 ;; k8 -- set 16-bit random seed
 382 ;; ( lo hi -- )
 383   pop   hl
 384   pop   de
 385   ld    a,l
 386   or    h
 387   or    d
 388   or    e
 389   jr    nz,fword_drandseed_ok
 390   inc   l
 391 fword_drandseed_ok:
 392   ld    (rndSeed0),hl
 393   ld    (rndSeed1),de
 394   jp    i_next
 395 $FORTH_END_CODE_WORD D-RANDSEED!
 396
 397
 398 $FORTH_CODE_WORD URANDOM
 399 ;; k8 -- generate 16-bit random number
 400 ;; ( -- n )
 401   call  random_marsaglia
 402   jp    i_pushhl
 403 $FORTH_END_CODE_WORD URANDOM
 404
 405 $FORTH_CODE_WORD RANDOM
 406 ;; k8 -- generate 15-bit random number
 407 ;; ( -- n )
 408   call  random_marsaglia
 409   res   7,h
 410   jp    i_pushhl
 411 $FORTH_END_CODE_WORD RANDOM
 412
 413
 414 $FORTH_CODE_WORD URANDOM8
 415 ;; k8 -- generate 8-bit random number
 416 ;; ( -- n )
 417   call  random_marsaglia
 418   ld    h,0
 419   jp    i_pushhl
 420 $FORTH_END_CODE_WORD URANDOM8
 421
 422 $FORTH_CODE_WORD URANDOM88
 423 ;; k8 -- generate two 8-bit random numbers
 424 ;; ( -- n n )
 425   call  random_marsaglia
 426   ld    e,h
 427   ld    h,0
 428   ld    d,h
 429   jp    i_pushde
 430 $FORTH_END_CODE_WORD URANDOM88