require my-colorize.fs

require fs-fonts/font-clb8x8.fs
: big-xy postpone clb8x8-string-xy ; immediate
4 constant big-w

require fs-fonts/font-clr5x8.fs
: thin-xy postpone clr5x8-string-xy ; immediate
3 constant thin-w

require fs-fonts/font-clr6x6.fs
: med-xy postpone clr6x6-string-xy ; immediate
3 constant med-w


\ optimized for 67x24
\ presentation german, code english

\ copy a string to a new memory location
: string-realloc ( addr u -- addr u )
    dup >r dup chars allocate throw dup >r swap cmove
    r> r>
;

\ output centered text on line
: center. ( addr u y -- )
    over cols - 2/ negate swap at-xy type
;

\ calculate where to start drawing a centered string
\ with characters of the given width
: to-center ( addr u cw -- addr u x )
    over * cols - 2/ negate
;

: center-xy ( y addr u w -- x y addr u )
    to-center >r rot r> swap 2swap
;

\ draw a centered string with the big font
: big-center. ( addr u y -- )
    -rot big-w center-xy big-xy
;

\ draw a centered string with the medium font
: med-center. ( addr u y -- )
    -rot med-w center-xy med-xy
;

\ draw a bullet
: bullet ( -- )
    <a red >fg a> attr!

    cr ."  ▣ "

    <a yellow >fg a> attr!
;

\ draw the space under the bullet
: bullet-space ( -- )
    ."    "
;

\ enable bold
: <bold ( -- )
    attr @ bold or attr!
;

\ disable bold
: bold> ( -- )
    attr @ bold - ( look at ansi.fs ) attr!
;

\ template stuff

\ insert the slide background 
: insert-background ( -- )
    <a black >bg red >fg a> attr!
    page

    0 5 at-xy cols 0 ?do ." ▂" loop
;

\ insert the title
: insert-title ( addr u -- )
    <a white >fg a> attr!
    1 1 2swap dup big-w * cols > if thin-xy else big-xy endif
;

\ position the cursor to insert contents
: insert-contents ( -- )
    <a yellow >fg a> attr!
    0 7 at-xy
;

\ wait for the next slide
: next-slide ( -- )
    key
;

\ insert a bullet prompt, return entered text
: prompt ( addr1 u1 - addr2 u2 )
    bullet <bold type bold> pad dup 84
    <a white >fg a> attr! accept
;

\ import the deferred version of the compressor
require lzw-deferred.fs

\ positions of the various "graphical" elements

11 constant begin-table-y

0 value table-y
13 constant input-y
18 constant output-y

35 constant put-x
25 constant recipient-size

4 constant entries-x
15 constant codes-x

24 constant end-table-x

0 value input-x
0 value output-x
0 value old-x

\ this is the presentation version of the deferred words

: pnext-code ( -- code )
    (next-code) dup
    drop
    \ show the code under the table, wait 1s
; latestxt is next-code

: pdictionary-add ( addr len code -- )
    \ add a new code at the bottom of the table
    >r 2dup 
       entries-x table-y at-xy type 
       codes-x table-y at-xy ." ▎"
       r@ .
       table-y 1+ to table-y
    r>
    (dictionary-add)
; latestxt is dictionary-add

: pdictionary-contains ( addr len -- contains? )
    \ highlight word if found
    2dup (dictionary-contains)
    >r r@ if
      dup 1 = if
        entries-x begin-table-y at-xy <bold ." ASCII" bold>
        key drop
        entries-x begin-table-y at-xy ." ASCII" 
        2drop
      else
        2dup (dictionary-get)
        255 - begin-table-y + entries-x swap
        2dup at-xy 2over <bold type bold>
        key drop
        at-xy type
      endif
    else
       dup >r entries-x table-y at-xy <bold type ."  nicht gefunden!" bold>
       key drop
       entries-x table-y at-xy r> 17 + spaces
    endif
   r>
; latestxt is dictionary-contains

: pdictionary-get ( addr len -- code )
    \ highlight the word and the code
    2dup
    (dictionary-get) dup >r
    key drop
    255 <= if
        2drop
        entries-x begin-table-y at-xy <bold ." ASCII" bold>
        codes-x begin-table-y at-xy ." ▎" r@ <bold emit bold>
        key drop
        entries-x begin-table-y at-xy ." ASCII"    
        codes-x begin-table-y at-xy ."    "
    else
        2dup
        r@
        255 - begin-table-y + >r r@ entries-x swap at-xy
        <bold type bold>
        codes-x r> at-xy ." ▎"
        r@ <bold . bold>

        key drop

        r@
        255 - begin-table-y + >r r@ entries-x swap at-xy
        type
        codes-x r> at-xy ." ▎"
        r@ .

    endif
    r>
; latestxt is dictionary-get

: draw-recipient ( x y -- )
    2dup at-xy ." ┃"
    2dup swap recipient-size + 1+ swap at-xy ." ┃"
    1+ at-xy ." ┗"
    recipient-size 0 ?do ." ━" loop
    ." ┛"
;

: pdictionary-init ( addr u -- addr u )
    \ init stuff, draw ascii part of table

    begin-table-y to table-y
    put-x to input-x
    put-x to output-x
    put-x to old-x

    entries-x table-y at-xy ." ASCII"
    table-y 1+ to table-y

    put-x 2 - input-y draw-recipient 

    put-x 2 - output-y draw-recipient


    entries-x 1- begin-table-y 1- at-xy ." ┏"
    end-table-x entries-x ?do ." ━" loop
    ." ┓"
    
    rows begin-table-y ?do 
      entries-x 1- i at-xy ." ┃"
      end-table-x i at-xy ." ┃"
    loop    

key drop
    
    (dictionary-init)
; latestxt is dictionary-init

: pdictionary-destroy
    (dictionary-destroy)
; latestxt is dictionary-destroy

: pcurrent-char ( len addr wlen -- len addr nwlen len<=nwlen )
    \ highlight
    rot 2dup 2>r -rot 2r> >= if
        input-x input-y at-xy ." ▣"
    else
        2dup chars + c@
        input-x dup input-y at-xy swap emit 1+ to input-x
    endif

    (current-char)
    
     key drop

; latestxt is current-char

: pdismiss-old-chars ( len addr wlen -- nlen naddr 1 )
    \ gray out old chars
    old-x input-y at-xy 
    dup 0 ?do ." ░" loop
    dup old-x + to old-x

    (dismiss-old-chars)
    key drop

; latestxt is dismiss-old-chars

: pcode-out ( code -- )
    \ output the code
    dup 255 < if
        output-x dup output-y at-xy swap emit 1+ to output-x
    else
        output-x dup output-y at-xy 
        swap <bold . bold> 3 + to output-x
    endif
    
; latestxt is code-out


\ this is where the fun should begin

: first-slide
    insert-background

    <a white >fg a> attr!
    s" LZW-Kompression" 7 big-center.
    s" in Forth" 12 med-center.

    <a bold a> attr!

    s" Mihai Ghete" 16 center.
    s" Florian Kimmel" 17 center.
    s" Jakob Petsovits" 18 center.

    next-slide
;


: info-slide
    insert-background
    s" Was ist LZW?" insert-title 
    insert-contents
    0 6 at-xy

    bullet ." LZW = Liv-Zempel-Welch" cr
    bullet ." Komprimiert Strings" cr
    bullet ." ... mit Hilfe einer "
    <bold ." string translation table" bold> cr

    next-slide
;

: example-slide
    insert-background
    s" Wie funktioniert LZW?" insert-title
    insert-contents
;


: example-loop
    begin
	example-slide
	
	s" Zu komprimierendes Wort: " prompt
	dup 0<>	while
	    string-realloc 2dup
	    lzw-compress
            key drop
	    drop free
	    
	repeat
;

: features-slide
    insert-background
    s" Sprach-Features" insert-title
    insert-contents
    
    bullet <bold ." Wordlists" bold> cr
    bullet-space ." LZW-Tabelle verwendet eine Wordlist zum Einfügen / Suchen" cr
    
    bullet <bold ." Deferred words" bold> cr
    bullet-space ." - " <bold ." see " bold> ." hat Farben!" cr
    bullet-space ." - Die Schritte des Kompressionsalgorithmus können neu definiert werden" cr
    bullet-space ."   (z.B. für die Präsentation)." cr

    next-slide
;

: words-slide
    insert-background
    s" Code" insert-title
    insert-contents

    bullet <bold ." Algorithmus: " bold> cr
    bullet-space ." lzw-compress" cr
    bullet-space ." current-char" cr
    bullet-space ." dismiss-old-chars" cr
    
    bullet <bold ." Tabelle: " bold> cr
    bullet-space ." dictionary-init" cr
    bullet-space ." dictionary-add" cr
    bullet-space ." dictionary-get" cr

;

\ see a word on a slide 

: fancy-see ( addr u -- )
    insert-background
    2dup insert-title
    insert-contents
    find-name dup 0=
    if
	." Wort nicht gefunden!"
	drop
    else
	name-see
    endif

    next-slide
;

: words-loop
    begin
	words-slide
	s" Wort: " prompt -trailing
	dup 0<> while
	    fancy-see
    repeat
;

: last-slide
    insert-background insert-contents
    <a white >fg a> attr!
    s" Ende" 7 big-center.
    s" Noch Fragen?" 12 med-center.
    next-slide
;

: bye
    <a a> attr!
    page
    bye
;

first-slide
info-slide
example-loop
words-loop
features-slide
last-slide
bye