@prog ansi-pose-fb6.muf
1 9999 d
i
( ansi-pose.muf -- Wog@SPR
  This is a program that will process ansi escape codes 
  and then poses them. Can be called from MPI, etc.
  For property info run with the argument #help.
  SETUP FOR NON-MPI USE:
   @action <pose command;pose command [use 'pose' for ':']>=
        me,<this program>

  NOTE:
   For those who do not want to see ansi-poses in there colors, they
  can '@set me=_prefs/apose/no_color?:yes'.

--- Change History ----------------------------------
v 1.0  02/24/00
    Assignment of version number to programs.
v 1.1  Mar 05 2000 
    Irrelevant to FB6 version.
v 1.2  Mar 12 2000
    Made proggie notify room for _listeners..
v 1.3  [Sorry, these modifications were only incorperated into
         the tidle ansi-version. I'll do this later.]
v 1.4  May 25 2000
    Added %n support.
v 1.5 7 May 2006
    Add extra security to %n. First word cannot match a real player's
    name. {Thanks to Scribbles@SPR.}
--- Distrubution Information ------------------------
Copyright {C} Charles "Wog" Reiss <car@cs.brown.edu>

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or {at your option} any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

For a copy of the GPL:
   a> see: http://www.gnu.org/copyleft/gpl.html
   b> write to: the Free Software Foundation, Inc., 
     59 Temple Place - Suite 330, Boston, MA  02111-1307, USA
)
$include $lib/case

$def textattr over swap 2 try \textattr 1 catch pop 0 endcatch if swap pop then 

: doHelp
  "ansi-pose.muf -- by Wog@Sociopolitical Ramifications" "green,bold" textattr .tell
  "Options:" "magenta,bold" textattr .tell
  "  #help" "white,bold" textattr "                 this screen" "cyan" textattr strcat .tell
  "Properties: (on you)" "magenta,bold" textattr .tell
  "  _prefs/apose/%n-name?:" "white,bold" textattr "  whther or not to use your %n-name." "cyan" textattr strcat .tell
  "  _prefs/apose/namecolor:" "white,bold" textattr " color of name" "cyan" textattr strcat .tell
  "  _prefs/apose/msgcolor:" "white,bold" textattr " default (escape code changable) color" "cyan" textattr strcat .tell
  "                             for the part of the pose after the name" "cyan" textattr .tell
  " Use valid arguments to the {attr:...} mpi for the coloring porps props." "cyan,bold" textattr .tell
  " Otherwise just use ^attrs valid tag^ in your pose." "cyan,bold" textattr .tell
  
  "This program (#" prog intostr strcat ") can be called from MPI." strcat "cyan" textattr  .tell
;

lvar tmp
lvar tmp2
: parse_attrs_inside ( s -- s' )
  "" tmp !
  "^" explode 1 - swap tmp2 ! 2 /
  array_make_dict
  foreach
    textattr tmp @ strcat tmp !
  repeat
  tmp2 @ tmp @ strcat
;

: strip_attrs_inside ( s -- s' )
  "" tmp !
  "^" explode 1 - swap tmp2 ! 2 /
  array_make_dict
  foreach
    pop tmp @ strcat tmp !
  repeat
  tmp2 @ tmp @ strcat
;

lvar stripped

(This will ansi_notify everything at location d, except for
  things who's owners are set _prefs/apose/no_color?:yes.)
: notify-loop ( s d -- )
  dup
  stripped @ notify
  contents
  begin
    dup ok? while
    dup dup owner "_prefs/apose/no_color?" getpropstr .yes? if
      stripped @ notify
    else
      3 pick notify
    then
    next
  repeat
;

: get-name
  me @ "_prefs/apose/%n-name?" getpropstr .yes? if
    me @ "%n" getpropstr dup not if pop me @ name exit then
    dup " " .split pop ansi_strip .pmatch if pop me @ name exit then
    tolower me @ name tolower 3 strncmp not if me @ "%n" getpropstr exit then
  then
  me @ name
;

: main 
  dup if dup "#help" stringpfx else 1 then if pop doHelp exit then
  get-name
  over
  (Smart name coloring here:
     Color <name>'s <name>: <name>? <name>! etc. as one.
  )
  case
    "'s" stringpfx when 
      "'s" strcat
      swap 2 strcut swap pop 
    end
    ". ,':!?-" swap 1 strcut pop instr when
      swap 1 strcut swap
      ( name msg 1st )
      rot swap strcat
      ( msg name )
      swap
    end
    default
      " " swap strcat
    end
  endcase
  swap

  dup stripped ! 
  me @ "_prefs/apose/namecolor" getpropstr dup if
    textattr
  else pop then
  
  swap
  dup strip_attrs_inside stripped @ swap strcat stripped !
  parse_attrs_inside
  me @ "_prefs/apose/msgcolor" getpropstr dup if
    textattr
  else pop then
  
  strcat
  
  me @ location notify-loop
;
.
c
q
@set ansi-pose-fb6.muf=L