; Diffusion Limited Aggregation
; B. Watson's asm rewrite of ChrisTOS's Atari 8-bit version.
; Original lives here: https://github.com/ctzio/DLA/

; This version uses ANTIC narrow playfield mode, since the original
; uses fewer than 256 columns of a GR.8 screen. This gives a slight
; speed boost for 2 reasons: less DMA from the ANTIC chip, and we get
; to use 1 byte for the X coordinate.

 .include "atari.inc"
 .include "xex.inc"

 loadaddr = $2000
 screen = $4000 ; must be on a x000 (4K) boundary
 screen2 = screen + $1000 ; rest of screen RAM after 4K boundary
 linelen = $20 ; aka 32 bytes, antic F (GR.8) in narrow mode.
 maxlines = $C0 ; 192 lines of display
 screenbytes = maxlines * linelen
 dl_len = 202 ; remember to update this if you modify the display list!
 dlist = screen - dl_len
 DMA_ON = $21
 DEFAULTPART = 1000
 linebuf = $0580
 textbuf = $0590

 .bss
 .org $80

maxparticles: .res 2 ; user's response to "How many particles?"
seedtype:     .res 1 ; user's response to seed type prompt (minus one; 0-3)

pixptr:       .res 2 ; used by plotsetup and friends
pixmask:      .res 1 ; ditto.
cursor_x:     .res 1 ; cursor x/y are args to plot/unplot/locate
cursor_y:     .res 1

min_x:        .res 1 ; limits: if the particle gets outside this box,
max_x:        .res 1 ; delete it and spawn a new one.
min_y:        .res 1
max_y:        .res 1

circlesize:   .res 1 ; 0 to 3

part_x:       .res 1 ; x/y coords of current particle
part_y:       .res 1
particles:    .res 2
spawn_x:      .res 2
spawn_y:      .res 2

cloksav:      .res 3 ; hold RTCLOK here while we convert to MM:SS.CC

old_dma:     .res 1 ; these 3 are for restoring GR.0 mode
old_dl:      .res 2
old_savmsc:  .res 2

tmp1:        .res 1
fptmp:       .res 6

 .code
 xex_org loadaddr
 .include "io.s" ; printchrx and getchrx
 .include "printint.s"
 .include "mmss.s"

 ; init stuff gets done once, at startup
init:
 lda #0
 sta seedtype ; default seed type is the single pixel
 sta LMARGN
 lda SDMCTL
 sta old_dma
 lda SDLSTL
 sta old_dl
 lda SDLSTH
 sta old_dl+1
 lda SAVMSC
 sta old_savmsc
 lda SAVMSC+1
 sta old_savmsc+1

 ; set default particles (if user just hits return)
 lda #<DEFAULTPART
 sta maxparticles
 lda #>DEFAULTPART
 sta maxparticles+1

 ; "New" option jumps here, restore GR.0 screen
getargs:
 jsr restore_gr0

 ; print banner and prompt.
printbanner:
 lda #<banner
 ldx #>banner
 jsr printmsg

 lda maxparticles
 ldx maxparticles+1
 jsr printdecw

 lda #<partprompt
 ldx #>partprompt
 jsr printmsg

 ; use CIO to read input, so user can use backspace/etc.
 jsr readline
 lda linebuf
 cmp #$9b
 beq usedefault ; if user hit Return
 ; use floating point ROM to convert input to an integer.
 lda #0
 sta CIX
 jsr AFP ; ASCII to floating point, result in FR0
 bcs printbanner ; C set means error
 jsr FPI ; convert FR0 to integer (result in FR0)
 bcs printbanner
 lda FR0
 tax
 ora FR0+1 ; we don't accept 0 for an answer!
 beq printbanner
 lda FR0+1
 stx maxparticles
 sta maxparticles+1

usedefault:

 ; print seed type prompt
 lda #<seedprompt
 ldx #>seedprompt
 jsr printmsg
 ldx seedtype
 inx
 txa
 jsr printdecb
 lda #<seedprompt2
 ldx #>seedprompt2
 jsr printmsg

readseed:
 jsr getchrx
 cmp #$9b
 beq dfltseed ; use default if user pressed return
 cmp #$31
 bcc readseed
 cmp #$35
 bcs readseed
 and #$0f
 tax
 dex
 stx seedtype
dfltseed:
 lda #$9b
 jsr printchr

generate: ;;; start of generate()
 jsr initscreen
 ; wait for shadow regs to get updated...
 lda RTCLOK+2
wl:
 cmp RTCLOK+2
 beq wl
 lda #1 ; ...turn off shadow reg updates (tiny speed boost)
 sta CRITIC
 lda #0
 sta particles
 sta particles+1
 sta RTCLOK
 sta RTCLOK+1
 sta RTCLOK+2
 sta circlesize
 jsr set_limits

 lda #<points_x
 sta spawn_x
 lda #>points_x
 sta spawn_x+1
 lda #<points_y
 sta spawn_y
 lda #>points_y
 sta spawn_y+1

 jsr drawseed

next_particle:
 ldy RANDOM ; spawn a new particle
 lda (spawn_x),y
 sta part_x
 lda (spawn_y),y
 sta part_y
 jsr drunkwalk     ; walk it around
 beq next_particle ; if it went out of bounds, try again

 ; particle stuck to an existing pixel, draw it
 lda part_x
 sta cursor_x
 lda part_y
 sta cursor_y
 jsr plot

 inc particles
 bne ph_ok
 inc particles+1
ph_ok:

 ; increase circlesize at appropriate particle counts
 ; if(particles == 100 || particles == 300 || particles == 600) goto next_size;
 lda particles
 ldx particles+1
 bne not_100
 cmp #100
 beq next_size
not_100:
 cpx #>300
 bne not_300
 cmp #<300
 beq next_size
not_300:
 cpx #>600
 bne checkmaxparts
 cmp #<600
 beq next_size
 bne checkmaxparts

next_size:
 inc circlesize
 jsr set_limits
 inc spawn_x+1
 inc spawn_y+1

checkmaxparts:
 ; if(particles != maxparticles) goto next_particle;
 lda particles
 cmp maxparticles
 bne next_particle
 lda particles+1
 cmp maxparticles+1
 bne next_particle

main_done:
 lda #0
 sta CRITIC
 sta COLOR2
 sta ATRACT
 lda #DMA_ON
 sta SDMCTL
 lda RTCLOK
 sta cloksav
 lda RTCLOK+1
 sta cloksav+1
 lda RTCLOK+2
 sta cloksav+2

 ; print elapsed time. see mmss.s for gory details.
 jsr print_mmss

 ; print menu, wait for keystroke.
 lda #<menumsg
 ldx #>menumsg
 jsr printmsg

 ; user might have hit some random key during plotting; ignore it.
 ldx #$ff
 stx CH

waitkey:
 jsr getchr

 ; see what key was hit
 and #$5f    ; ignore case
 cmp #'R'    ; Redo
 bne notredo
 jmp generate
notredo:
 cmp #'S'    ; Save
 beq saveimage
 cmp #'N'    ; New
 bne waitkey ; ignore any other keystroke
 jmp getargs
 ;;; End of generate()

;;; Subroutine: saveimage
;;; Does exactly what it says on the tin: saves the image.
;;; User is prompted for a filename. In case of disk error,
;;; there's a "Retry [Y/n]?" prompt.
saveimage:
 jsr restore_gr0  ; back to GR.0, so we can...
 lda #<saveprompt
 ldx #>saveprompt
 jsr printmsg     ; ...prompt for, and...
 jsr readline     ; ...let the user type a filename.

 jsr close1       ; make sure the IOCB is closed before we open it!

 ; CIO is nice, but it's kind of a PITA to use...
 ; OPEN #1,8,0,<filename>
 ldx #$10
 lda #3 ; OPEN
 sta ICCOM,x
 lda #<linebuf
 sta ICBAL,x
 lda #>linebuf
 sta ICBAH,x
 ldy ICBLL ; length returned by CIO when we called readline...
 dey       ; ...but one byte too long.
 tya
 sta ICBLL,x
 lda #0
 sta ICBLH,x
 sta ICAX2,x
 lda #8
 sta ICAX1,x
 jsr CIOV
 cpy #1   ; CIO returns with Y=1 for success.
 bne save_error

 ; write data to the channel
 ldx #$10
 lda #$0b ; write binary record
 sta ICCOM,x
 lda #<screen
 sta ICBAL,x
 lda #>screen
 sta ICBAH,x
 lda #<screenbytes
 sta ICBLL,x
 lda #>screenbytes
 sta ICBLH,x
 jsr CIOV
 cpy #1
 bne save_error

 ; close the channel
 jsr close1
 cpy #1
 bne save_error

 ; let the user know the save worked.
 lda #<saveokmsg
 ldx #>saveokmsg
 jsr printmsg
 jsr getchr ; any key
 jmp getargs

 ; print error message, prompt for retry.
save_error:
 tya
 pha
 lda #<diskerrmsg
 ldx #>diskerrmsg
 jsr printmsg
 pla
 jsr printdecb
 lda #<retrymsg
 ldx #>retrymsg
 jsr printmsg
get_retry_key:
 jsr getchr
 cmp #$9b ; return = yes
 beq jsaveimage
 and #$5f ; ignore case
 cmp #'Y'
 beq jsaveimage
 cmp #'N'
 bne get_retry_key
 jmp getargs
jsaveimage:
 lda #$9b
 jsr printchr
 jmp saveimage

;;; Subroutine: set_limits
;;; Sets the X/Y min/max limits based on circlesize
set_limits:
 ldx circlesize
 lda xmin,x
 sta min_x
 lda ymin,x
 sta min_y
 lda xmax,x
 sta max_x
 lda ymax,x
 sta max_y
 rts

;;; Subroutine: initscreen
;;; clear screen memory and point ANTIC to our display list.
;;; no arguments. trashes all registers.
initscreen:
 lda #<screen
 sta pixptr
 lda #>screen
 sta pixptr+1

 ; first, clear linebuf and textbuf
 lda #0
 tay
isloop0:
 sta linebuf,y
 iny
 cpy #$40
 bne isloop0

 ; next, clear screen memory
 ldx #>screenbytes ; clear this many pages
 tay ; 0 again
isloop:
 sta (pixptr),y
 iny
 bne isloop
 inc pixptr+1
 dex
 bne isloop

 lda #DMA_ON   ; set ANTIC narrow playfield mode
 sta SDMCTL

 lda #<dlist ; use our display list
 sta SDLSTL
 lda #>dlist
 sta SDLSTH

 lda #<textbuf
 sta SAVMSC
 lda #>textbuf
 sta SAVMSC+1
 lda #0
 sta ROWCRS
 sta COLCRS
 sta COLCRS+1
 rts

;;; Subroutine: plotsetup
;;; - set pixptr to point to screen memory at cursor_y.
;;; - set pixmask to the mask for cursor_x.
;;; - set Y reg to the byte offset for cursor_x.
;;; - returns with cursor_x in X reg, pixmask in A reg too.
;;; Called by plot, unplot, and drunkwalk (a lot!)
plotsetup:
 ldx cursor_y
 lda lineaddrs_l,x
 sta pixptr
 lda lineaddrs_h,x
 sta pixptr+1

 ldx cursor_x
 ldy xoffsets,x
 lda xmasks,x
 sta pixmask

 rts

;;; Subroutine: plot
;;; plots a pixel at (cursor_x, cursor_y)
plot:
 jsr plotsetup
 lda (pixptr),y
 ora pixmask
 sta (pixptr),y
 rts

;;; Subroutine: unplot
;;; erases a pixel at (cursor_x, cursor_y)
unplot:
 jsr plotsetup
 lda pixmask
 eor #$ff
 sta pixmask
 lda (pixptr),y
 and pixmask
 sta (pixptr),y
 rts

;;; Subroutine: locate
;;; check the pixel at (cursor_x, cursor_y)
;;; if set, return with Z=0
;;; otherwise, return with Z=1
;;;; Inlined (keep for reference)
;locate:
; jsr plotsetup
; and (pixptr),y
; rts

;;; Subroutine: spawn
;;; Pick a random point on the edge of a circle
;;;; Inlined (keep for reference)
; spawn:
;  ldy RANDOM
;  lda (spawn_x),y
;  sta part_x
;  lda (spawn_y),y
;  sta part_y
;  rts

oob:
 rts
;;; Subroutine: drunkwalk
;;; Walk the point around randomly until it either is
;;; adjacent to a set pixel or goes out of bounds.
;;; Return with Z=0 if out of bounds, Z=1 if it hit a pixel.
;;; This is the innermost loop, so it should be as optimized as
;;; possible (we're not there yet).
drunkwalk:
 ; using bit/bmi/bvc saves 6.25 cycles on average, compared to
 ; immediate cmp and bne.
 ; 4 code paths: up=14, down=15, left=15, right=13, avg=14.25
 bit RANDOM ;4 ; use top 2 bits (probably more random, definitely faster)
 bmi lr     ;2/3
 bvc down   ;2/3
 dec part_y ;3 ; N=1 V=1 up
 bne checkbounds ;3
down:
 inc part_y ;3 ; N=1 V=0 down
 bne checkbounds ;3
lr:
 bvc right ;2/3
 dec part_x ;3 ; N=0 V=1 left
 bne checkbounds ;3
right:
 inc part_x ;3

checkbounds:
 lda part_x
 cmp min_x
 beq oob
 cmp max_x
 beq oob
 sta cursor_x
 lda part_y
 cmp min_y
 beq oob
 cmp max_y
 beq oob
 sta cursor_y

 ldx #0
 lda CONSOL
 cmp #6
 bne dontplot
 jsr plot
 jsr unplot
 ldx #DMA_ON
dontplot:
 ;stx SDMCTL ; nope, shadow updates are off...
 stx DMACTL

 ; check neighbors. used to be a subroutine, inlined it.
 ; also inlined plotsetup here.
 ldx cursor_y
 lda lineaddrs_l,x
 sta pixptr
 lda lineaddrs_h,x
 sta pixptr+1

 ; 3/4 of the time, we can use a faster code path, check
 ; (-1,0) and (1,0) at the same time. this happens only when
 ; both pixels lie within the same byte.
 ldx cursor_x
 lda fastmasks,x
 beq slow_x
 ldy xoffsets,x
 and (pixptr),y
 bne stick
 beq check_y
slow_x:
 ; (-1,0)
 ldx cursor_x
 ldy xoffsets-1,x
 lda xmasks-1,x
 and (pixptr),y
 bne stick
 ; (1,0)
 ldy xoffsets+1,x
 lda xmasks+1,x
 and (pixptr),y
 bne stick
check_y:
 ; (0,-1)
 ldx cursor_y        ;3
 lda lineaddrs_l-1,x ;5
 sta pixptr          ;3
 lda lineaddrs_h-1,x ;5
 sta pixptr+1        ;3
                     ;=19
 ldx cursor_x
 ldy xoffsets,x
 lda xmasks,x
 sta pixmask
 and (pixptr),y
 bne stick
 ; (0,1)
 tya
 ora #$40 ; add 64, AKA 2 screen lines
 tay
 lda (pixptr),y
 and pixmask
 bne stick
 jmp drunkwalk ; too far for a branch

stick:
 rts

;;; Subroutine: drawseed
;;; dispatch to appropriate seed subroutine
drawseed:
 ldx seedtype
 lda seeds_h,x
 pha
 lda seeds_l,x
 pha
 rts

;;; Subroutine: seed_point
;;; draw initial point in center
seed_point:
 lda #$7f
 sta cursor_x
 lda #$5f
 sta cursor_y
 jmp plot

;;; Subroutine: seed_long
;;; horizontal line, the width of the screen
seed_long:
 lda #$1
 sta cursor_x
 lda #$5f
 sta cursor_y
slnoop:
 jsr plot
 inc cursor_x
 lda cursor_x
 cmp #$ff
 bne slnoop
 rts

;;; Subroutine: seed_plus
;;; plus share, made of two 20px lines intersecting in the center
seed_plus:
 lda #$7f
 sta cursor_x
 lda #$55
 sta cursor_y
sploop:
 jsr plot
 inc cursor_y
 lda cursor_y
 cmp #$69
 bne sploop
 lda #$75
 sta cursor_x
 lda #$5f
 sta cursor_y
slloop:
 jsr plot
 inc cursor_x
 lda cursor_x
 cmp #$89
 bne slloop
 rts

;;; Subroutine: seed_4pt
;;; four points, the corners of a 20px square
seed_4pt:
 lda #$75
 sta cursor_x
 lda #$55
 sta cursor_y
 jsr plot
 lda #$68
 sta cursor_y
 jsr plot
 lda #$88
 sta cursor_x
 jsr plot
 lda #$55
 sta cursor_y
 jmp plot

;;; Subroutine: readline
;;; Read a line from E:, store result in linebuf.
;;; The terminating EOL ($9b) gets stored at the end.
;;; linebuf happens to be right where the FP ROM needs it for AFP.
readline:
 lda #<linebuf
 sta INBUFF
 sta ICBAL
 lda #>linebuf
 sta INBUFF+1
 sta ICBAH
 lda #0
 sta ICBLH
 lda #32 ; buffer length; longer than we need
 sta ICBLL
 lda #5
 sta ICCOM
 ldx #0
 jmp CIOV

;;; Subroutine: restore_gr0
;;; Restore the OS's GRAPHICS 0 display, so we can use E:
restore_gr0:
 lda #$90
 sta COLOR2
 lda #$0e
 sta COLOR1
 lda #$ff
 sta CH
 lda old_dl
 sta SDLSTL
 lda old_dl+1
 sta SDLSTH
 lda old_dma
 sta SDMCTL
 lda old_savmsc
 sta SAVMSC
 lda old_savmsc+1
 sta SAVMSC+1
 rts

;;; Subroutine: close1
;;; Closes IOCB 1, same as CLOSE #1 in BASIC.
close1:
 ldx #$10
 lda #$0c ; close
 sta ICCOM,x
 jmp CIOV

;;;;; end of executable code, data tables from here on out.

; prompts.
; banner and saveprompt must start with a clear-screen code.
banner:
 .byte $7d, "Diffusion Limited Aggregate",$9b
 .byte "Urchlay's ASM version 0.0.99",$9b,$9b
 .byte "Particle count range: 1 to 65535",$9b
 .byte "How many particles [",$0

partprompt:
 .byte "]? ",$0

seedprompt:
 .byte $9b,"Seed Type: ",$9b,"1=Dot 2=Plus 3=4Dots 4=Line [",$0

seedprompt2:
 .byte "]? ",$0

saveprompt:
 .byte $7d, "Save: Enter filename, including Dn:",$9b,"> ",$0

saveokmsg:
 .byte "Saved OK, press any key...",$0

diskerrmsg:
 .byte "I/O Error ",$0

retrymsg:
 .byte "  Retry [Y/n]? ",$0

; this prompt has to be <22 bytes long, and can NOT contain any
; screen control codes, because when it's printed we're only
; printing to a 32-byte buffer (which we told the OS was the
; start of a GR.0 screen, but that was designated "a lie").
menumsg:
 .byte "   "
 .byte ' ','S'|$80,"ave"
 .byte ' ','R'|$80,"edo"
 .byte ' ','N'|$80,"ew? "
 .byte 0

 ; jump table for seed functions
seeds_l: .byte <(seed_point-1),<(seed_plus-1),<(seed_4pt-1),<(seed_long-1)
seeds_h: .byte >(seed_point-1),>(seed_plus-1),>(seed_4pt-1),>(seed_long-1)

 ; dlatbl.s is generated by perl script, mkdlatbl.pl
 .include "dlatbl.s"

 ; table of addresses, for each line on the screen. bloats the
 ; code by 384 bytes, but compared to calculating the address, is
 ; twice as fast!
lineaddrs_l:
 laddr .set screen
 .repeat 192
  .byte <laddr
  laddr .set laddr + $20
 .endrep

lineaddrs_h:
 laddr .set screen
 .repeat 192
  .byte >laddr
  laddr .set laddr + $20
 .endrep

 ; tables to replace X coord => mask-and-offset calculations.
xoffsets:
 xoffs .set 0
 .repeat 32
  .repeat 8
   .byte xoffs
  .endrep
  xoffs .set xoffs + 1
 .endrep

xmasks:
 .repeat 32
  .byte $80,$40,$20,$10,$08,$04,$02,$01
 .endrep

fastmasks:
 .repeat 32
  .byte $00,$a0,$50,$28,$14,$0a,$05,$00
 .endrep

;;; display list
 ; ANTIC opcodes
 blank8 = $70
 gr8    = $0f
 gr0    = $02
 lms    = $40
 jvb    = $41

 xex_org dlist
 .byte blank8, blank8, blank8
 .byte gr8 | lms
 .word screen
 .repeat 127
  .byte gr8
 .endrep
 .byte gr8 | lms
 .word screen2
 .repeat maxlines - 132
  .byte gr8
 .endrep
 .byte gr0 | lms
 .word textbuf
 .byte jvb
 .word dlist

 xex_run init