\ +------------------------------------------------------------------------------------------------------+
\ |                                 wiki markup to html processor                                        |
\ +------------------------------------------------------------------------------------------------------+

\ v0.07 2005jan9 added named image links (click on image to connect to url)
\ v0.06 2005jan8 added named http links, empty lines for double line feed, | for single line feed
\ v0.05 2005jan7 simplified a bit here and there, moved -scan$ to stringstack
\ v0.04 2005jan6 bold, italics, underscore.
\ v0.03 2005jan5 fixed unclosed <li> in bullets, added link types  mailto, http, png/jpg/gif image links
\ v0.02 2005jan5 single-lines most of it, added WikiLinks, [wikilinks], link prevention
\ v0.01 2005jan4 initial implementation, can header, bullet, indent



\ --------------------------------- configuration ------------------------------


\ html is produced as output while source is loaded - redefinition warning
\ and other must be turned off lest they'd be visible on the html page.

warnings dup @ swap off       


\ without the library, you'd set this to false to use the definitions
\ of general purpose words as provided by this source file. The advantage
\ of including from the library is that redefinitions are avoided if a word
\ is required by several source modules.

   true \ false  
   constant use_library


\ location of the wiki pages repository
\   : cookedpages ( -- a n )     s" http://fwiki.logilan.com/pages"  ;
   : rawpages    ( -- a n )     s" /rawpages"  ;
   : cookedpages ( -- a n )     s" /pages"  ;
   

warnings !
decimal


\ ------------------------------------- general purpose ----------------------------------------------



use_library [if]

   require exchange      require itoa      require capital?     require quote
   require null$     require hasn't        require enclosed?

[else]

   : exchange ( x1 a -- x2 )     dup @ -rot ! ;
   : itoa   ( n -- a n )   0 <# #s #>  ;
   : capital? ( c -- flag )    'A 'Z 1+ within  ;
   : quote   ( a n -- )    '" emit type '" emit  ;
   : null$ ( -- a n )    s" " ;
   : hasn't  ( <stream> -- )  bl word find nip 0 word swap 0= if count type quit then drop ;
   : enclosed? ( a1 n1 a2 n2 -- f ) drop count swap c@ 2>r over c@ -rot + 1- c@ 2r> d= ;

[then]



\ --------------------------------- string support --------------------------------------------------

require stringstack    ( http://forthfreak.net/stringstack )
hasn't -skip$ need a more recent stringstack (v0.10+)

: -trailing$ ( c -- )                      -skip$ left$  ;
: -leading$  ( c -- )                      skip$ right$  ;


\ ------------------------------------- wiki markup to html ------------------------------------------


create attributes 0 c, 255 allot
: +attribute    ( c -- )                   attributes count dup 255 < if 2dup 1+ swap 1- c! + 2dup c! dup  then 2drop drop ;
: -attribute    ( -- )                     attributes count ?dup if 1- over 1- c! then drop ;
: @attribute    ( -- c )                   attributes count + 1- c@  ;


create bulletdepth  0 ,

: tag    ( a n -- )                        ." <"   type ." >"  ;
: /tag   ( a n -- )                        ." </"  type ." >"  ;
: newbulletdepth ( n -- )                  dup bulletdepth exchange - dup 0< if abs s" /ul" else s" ul" then  rot 0 ?do 2dup tag loop 2drop  ;
: unbullet  ( -- )                         0 newbulletdepth ;
: url   ( a1 n1 -- a2 n2 )                 cookedpages push$  s" /" push$ push$ merge$ merge$ pop$ ;
: mailaddress ( a1 n1 -- a2 n2 )           s" mailto:" push$             push$        merge$ pop$ ;
: partition$ ( c -- n )                    dup -leading$ scan$  ;
: tokenize$ ( c -- n )                     depth$ >r begin dup partition$ ?dup while negate split$  repeat drop depth$ r> - 1+ ;
: imageextension ( a n -- f )              s" png gif jpg" push$  bl tokenize$ dup >r searchn$ dup if nip then r> dropn$ ;
: hreflink   ( a1 n1 a2 n2 xt -- )         >r ." <a href=" 2swap r> execute quote ." >" type s" a" /tag  ;
: linebreak ( -- )                         ." <br>"  ;
: .tagged ( a1 n1 a2 n2 -- )               2dup tag 2swap type /tag  ;
: indentedwikiline ( a n -- )              unbullet s" pre" .tagged  ;


8 constant #linktypes
create linktype    #linktypes cells allot 
create linkaction  #linktypes cells allot
: !linktype   ( xt1 xt2 n -- )  cells tuck linkaction + ! linktype + !  ;

: wikidolinktype ( a1 n1 -- a2 n2)   #linktypes      0 do 2dup i cells linktype      + perform  if  i cells linkaction      + perform leave then loop ;

: preventedlink       ( a n -- flag )      drop c@ '! =  ;
: preventedlinkaction ( a1 n1 -- a2 a2 )   1 /string ; 
' preventedlink ' preventedlinkaction  0 !linktype

: WikiWord? ( a n -- flag )                0 -rot ?dup if 1 ?do count capital? over c@ capital? <> 1 and rot + swap loop then drop 1 > ;
: WikiWordaction  ( a1 n1 -- a2 n2 )       2dup ['] url  hreflink null$  ;
' WikiWord? ' WikiWordAction  1 !linktype

: [wikiword]? ( a n -- flag )              s" []" enclosed?  ; 
: [wikiword]action    ( a1 n1 -- a2 n2 )   1 /string 1- WikiWordaction ;
' [wikiword]? ' [wikiword]action    2 !linktype  


: httplink?   ( a n -- flag )              drop s" http:" tuck compare 0=  ;
: httplinkaction  ( a1 n1 -- a2 n2 )       2dup ['] noop hreflink null$ ;
' httplink? ' httplinkaction 6 !linktype

: imagelink? ( a n -- flag )               2dup httplink? -rot dup 3 - /string imageextension and  ;
: imagelinkaction ( a1 n1 -- a2 n2 )       ." <p><img src=" 2dup quote ."  alt="  push$ '/ -scan$ negate right$ pop$ quote  ." ></p>" null$ ;
' imagelink? ' imagelinkaction 5 !linktype

: namedlink?  ( a1 n1 -- flag )            over c@ '[ = -rot 1 /string httplink? and  ;
: namedlinkaction ( a1 n1 -- a2 n2 )       1 /string  ." <a href=" quote ." >"  'l +attribute null$ ;
' namedlink? ' namedlinkaction 3 !linktype

: endnamedlink? ( a1 n1 -- flag )          + 1- c@ '] =  @attribute 'l = and ;
: endnamedlinkaction ( a1 n1 -- a2 n2 )    1-  2dup imagelink? if imagelinkaction 2drop else type then s" a" /tag -attribute null$ ;
'  endnamedlink? '  endnamedlinkaction 4 !linktype

: mailto?   ( a n -- flag )                '@ scan tuck '. scan nip - 1 >  ;
: mailtoaction ( a1 n1 -- a2 n2 )          2dup ['] mailaddress hreflink null$  ;  
' mailto? ' mailtoaction 7 !linktype




: unattributify:   create ( c -- ) c, does> ( a1 n1 -- a2 n2 ) 1 2swap 1- type /tag -attribute null$ ;
'b unattributify: unboldify
'i unattributify: unitalify
'u unattributify: ununderscorify

: attributify?:    create ( c -- ) c, does> ( a n -- flag ) c@ >r 1 > if  count r@ = swap c@ bl <> and else drop 0 then rdrop ; 
'* attributify?: boldify?
'/ attributify?: italify?
'_ attributify?: underscorify?

: unattribute?:    create ( c -- ) c, does> ( a n -- f ) c@ >r dup 1 > if 2 - + count bl <> swap c@ r@ = and dup if @attribute r@ = and then else 2drop 0 then rdrop ;
'* unattribute?: unboldify?
'/ unattribute?: unitalify?
'_ unattribute?: ununderscorify?

: attributify ( a n c -- )                 +attribute tag ;
: boldify      ( a1 n1 -- a2 n2 )          s" b"  '* attributify  1 /string 2dup unboldify? if unboldify then ;
: italify      ( a1 n1 -- a2 n2 )          s" i"  '/ attributify  1 /string 2dup unitalify? if unitalify then ;
: underscorify ( a1 n1 -- a2 n2 )          s" u"  '_ attributify  1 /string 2dup ununderscorify? if ununderscorify then ;

: linefeed?    ( a1 n1 -- flag )           + 1- c@ '| = ;
: linefeedify  ( a1 n1 -- a2 n2 )          1- type linebreak null$ ;



create attributetype       ' boldify? ,  ' unboldify? ,   ' italify? ,  ' unitalify? ,  ' underscorify? ,  ' ununderscorify? ,  ' linefeed? ,
create attributeaction     ' boldify ,   ' unboldify ,    ' italify ,   ' unitalify ,   ' underscorify ,   ' ununderscorify ,   ' linefeedify ,
7 constant #attributetypes
: wikidoattrtype ( a1 n1 -- a2 n2 )  #attributetypes 0 do 2dup i cells attributetype + perform  if  i cells attributeaction + perform leave then loop ;


: wikiword  ( a1 n1 -- )                   wikidolinktype  dup if wikidoattrtype then type space ;
: .wikiwords ( n -- )                      begin ?dup while 1- dup pick$ wikiword repeat ;

: header: create 1+ dup , does> @    unbullet      s" H" push$ itoa push$ merge$ pop$ 2dup tag rot 1- .wikiwords /tag  ;
: bullet: create 1+ dup , does> @ newbulletdepth   s" li" tag 1- .wikiwords s" li" /tag ;
: hardreturn: create      does>      unbullet      ." <hr>" ;


\ --------------------------- wiki markup tokens ---------------------------------------------

vocabulary wiki
also wiki definitions

0
header: =
header: ==
header: ===
header: ====
header: =====
header: ======
drop

0
bullet: *
bullet: **
bullet: ***
bullet: ****
bullet: *****
bullet: ******
drop

hardreturn: ---
hardreturn: ----
hardreturn: -----
hardreturn: ------


get-current
previous definitions
constant wiki-wordlist

    

\ -------------------------- wiki input line processing -----------------------------------

: endwikiline ( n -- )                     1+ 0 ?do drop$ loop free$   ;
: .wikiline   ( n -- )                     unbullet .wikiwords ;
: wikimarkup ( a1 n -- a2 -1 | 0 )         wiki-wordlist search-wordlist ;
: firststring ( n1 -- a n2 )               1- pick$  ;
: splitstring ( a n1 -- n2 )               push$ dup$ bl tokenize$  ;
: wikiline ( a n -- )                      splitstring dup firststring wikimarkup if 2dup execute drop else dup .wikiline then endwikiline ;
: wikify ( a n -- )                        dup if cr over c@ bl = if indentedwikiline else wikiline then else 2drop linebreak linebreak then ;
: w ( <string> -- )                        0 word count wikify  ;




\ ------------------------------ demo and test -----------------------------------

.( Content-Type: text/html)
cr
.( <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">)
cr
cr