You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
436 lines
9.7 KiB
436 lines
9.7 KiB
#<?xml version="1.0"?> |
|
#<xml> |
|
#<xpack> |
|
#<code> |
|
#<![CDATA[ |
|
# Author: Julian Marcel Noble <julian@cyberclad.com> |
|
# 2004 - Public Domain |
|
# |
|
# PatternPunk - DIALECT |
|
#Dynamic Instance Accumulation Language Extending Classic Tcl |
|
#The goofy acronym is a fancy way of not referring to PatternPunk as yet another OO system. |
|
|
|
|
|
package require pattern |
|
package require overtype |
|
package require punk::args |
|
package require punk::ansi |
|
package require punk::lib |
|
pattern::init |
|
|
|
|
|
|
|
::>pattern .. Create ::>punk |
|
::>punk .. Property license {Public Domain} |
|
::>punk .. Property logo_ascii [string trim { |
|
+-----------------------+ |
|
| Pattern PUNK | |
|
| . \\\_ . | |
|
| .*. \@ > .=. | |
|
| .*.*. | ~ .=.=. | |
|
|.*.*.*.\_- -_/.=.=.=.| |
|
| .*.*. \\ .=.=. | |
|
| .*. / \ .=. | |
|
| . _+ +_ . | |
|
+-----------------------+ |
|
} \n] |
|
set ::punk::bannerTemplate0 [string trim { |
|
+-----------------------+ |
|
| .000000000000000. | |
|
| .*. \\\_ .=. | |
|
| .*.*. \@ > .=.=. | |
|
|.*.*.*. | ~ .=.=.=.| |
|
| .*.*. \_- -_/ .=.=. | |
|
| .*. \\ .=. | |
|
| . / \ . | |
|
|111111111_+ +_2222222| |
|
+-----------------------+ |
|
} \n] |
|
set ::punk::bannerTemplate [string trim { |
|
.000000000000000. |
|
.*. \\\_ .=. |
|
.*.*. \@ > .=.=. |
|
.*.*.*. | ~ .=.=.=. |
|
.*.*. \_- -_/ .=.=. |
|
.*. \\ .=. |
|
. / \ . |
|
111111111_+ +_2222222 |
|
} \n] |
|
|
|
>punk .. Method banner {args} { |
|
set defaults [list -title "Pattern PUNK" -left "" -right ""] |
|
if {[catch {set opts [dict merge $defaults $args]} ]} { |
|
error "usage: banner \[-title \$title -left \$left -right \$right\]" |
|
} |
|
|
|
set word1 [overtype::left [string repeat " " 9] [dict get $opts -left]] |
|
set word2 [overtype::right [string repeat " " 7] [dict get $opts -right]] |
|
set title [overtype::centre [string repeat " " 15] [dict get $opts -title]] |
|
return [string map [list 111111111 $word1 2222222 $word2 000000000000000 $title] $::punk::bannerTemplate] |
|
} |
|
|
|
>punk .. Property logo2 "\[TCL\\\nPUNK\]" |
|
>punk .. Method logo3 {{cborder_ctext ""}} { |
|
set this @this@ |
|
if {$cborder_ctext eq ""} { |
|
set cborder "web-seagreen" |
|
set ctext "web-steelblue" |
|
} else { |
|
lassign $cborder_ctext cborder ctext |
|
} |
|
return [ textblock::frame -checkargs 0 -type arc -ansiborder [a+ Web-black $cborder] [a+ Web-black $ctext][$this . logo2]] |
|
} |
|
>punk .. Property logotk "\[TCL\\\n TK \]" |
|
proc TCL {args} { |
|
switch -- [lindex $args 0] { |
|
TK { |
|
return [>punk . logotk .] |
|
#return [textblock::frame -type arc [>punk . logotk]] |
|
} |
|
PUNK { |
|
return [>punk . logo2 .] |
|
#return [textblock::frame -type arc [>punk . logo2]] |
|
} |
|
default { |
|
return [textblock::join -- [>punk . logo3] " " "\nmodule : patternpunk\nversion: [package present patternpunk]"] |
|
} |
|
} |
|
} |
|
>punk .. Property logo [>punk . banner] |
|
>punk .. Method versionLogo {} { |
|
set this @this@ |
|
>punk . banner -left " Ver" -right "[$this . version] " |
|
} |
|
|
|
>punk .. Method version {} { |
|
if {[package provide punk] ne ""} { |
|
set version $::punk::version |
|
} else { |
|
set version "N/A" |
|
} |
|
return $version |
|
} |
|
|
|
punk::args::define { |
|
#Review |
|
@id -id ">punk . poses" |
|
@cmd -name ">punk . poses" -help "Show or list the poses for the Punk mascot" |
|
-censored -default 1 -type boolean -help "Set true to include mild toilet humour poses" |
|
-return -default table -choices {list table} |
|
} |
|
>punk .. Method poses {args} { |
|
set argd [punk::args::get_by_id ">punk . poses" $args] |
|
set censored [dict get $argd opts -censored] |
|
set return [dict get $argd opts -return] |
|
|
|
set poses [list\ |
|
front\ |
|
back\ |
|
lhs\ |
|
left\ |
|
rhs\ |
|
right\ |
|
lhs_air\ |
|
rhs_air\ |
|
lhs_hips\ |
|
rhs_hips\ |
|
lhs_bend\ |
|
rhs_bend\ |
|
lhs_thrust\ |
|
rhs_thrust\ |
|
] |
|
if {!$censored} { |
|
#allow toilet humour |
|
lappend poses piss poop |
|
} |
|
if {$return eq "list"} { |
|
return $poses |
|
} |
|
set cells [list] |
|
foreach pose $poses { |
|
lappend cells "$pose\n\n[>punk . $pose]" |
|
} |
|
textblock::list_as_table -show_hseps 1 -columns 4 $cells |
|
} |
|
|
|
>punk .. Property front [string trim { |
|
_|_ |
|
@ v @ |
|
~ |
|
- - |
|
|_\ /_| |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
>punk .. Property front_2003 [string trim [string map "% \u2003" { |
|
_|_ |
|
@%v%@ |
|
%~% |
|
-%%%- |
|
|_\%/_| |
|
/ \ |
|
_+ +_ |
|
}] \n] |
|
>punk .. Property back [string trim { |
|
| |
|
( | ) |
|
| |
|
- - |
|
|_\ /_| |
|
/ \ |
|
_- -_ |
|
} \n] |
|
>punk .. Property rhs [string trim { |
|
\\\_ |
|
\@ > |
|
| ~ |
|
\_- -_ |
|
\\ / |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
>punk .. Property rhs_2003 [string trim [string map "% \u2003" { |
|
\\\_ |
|
\@%%> |
|
|%~ |
|
\_-%%%-_ |
|
\\ / |
|
/ \ |
|
_+ +_ |
|
}] \n] |
|
>punk .. Property right |
|
>punk .. PropertyRead right {} { |
|
return $o_rhs |
|
} |
|
|
|
|
|
>punk .. Property lhs [string trim { |
|
_/// |
|
< @/ |
|
~ | |
|
_- -_/ |
|
\ // |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
>punk .. Property lhs_2003 [string trim [string map "% \u2003" { |
|
_/// |
|
<%%@/ |
|
~%| |
|
_-%%%-_/ |
|
\ // |
|
/ \ |
|
_+ +_ |
|
}] \n] |
|
>punk .. Property left |
|
>punk .. PropertyRead left {} { |
|
return $o_lhs |
|
} |
|
|
|
>punk .. Property rhs_air [string trim { |
|
\\\_ |
|
\@ > |
|
| ~ |
|
\_- -_/ |
|
\\ |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
>punk .. Property lhs_air [string trim { |
|
_/// |
|
< @/ |
|
~ | |
|
\_- -_/ |
|
// |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
|
|
>punk .. Property lhs_hips [string trim { |
|
_/// |
|
< @/ |
|
~ | |
|
_- -_ |
|
\ | | / |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
>punk .. Property rhs_hips [string trim { |
|
\\\_ |
|
\@ > |
|
| ~ |
|
_- -_ |
|
\ | | / |
|
/ \ |
|
_+ +_ |
|
} \n] |
|
|
|
|
|
>punk .. Property piss [string trim { |
|
\\\_ |
|
\@ > |
|
| ~ |
|
\_- -_/ |
|
\\_ .. |
|
/ \ .. |
|
_+ +_ . |
|
} \n] |
|
|
|
>punk .. Property poop [string trim { |
|
_/// |
|
< @/ |
|
~ | |
|
_- -_ |
|
\ \\ / |
|
//. ~ |
|
_+_+ @ |
|
} \n] |
|
|
|
>punk .. Property lhs_bend [string trim { |
|
_/// |
|
< @/ |
|
~ | |
|
_- -_ |
|
\ \\ / |
|
// |
|
_+_+ |
|
} \n] |
|
>punk .. Property lhs_thrust [string trim { |
|
_/// |
|
< @/ |
|
~ | |
|
_- -_ |
|
\ // / |
|
\\ |
|
_+_+ |
|
} \n] |
|
>punk .. Property rhs_bend [string trim { |
|
\\\_ |
|
\@ > |
|
| ~ |
|
_- -_ |
|
\ // / |
|
\\ |
|
+_+_ |
|
} \n] |
|
>punk .. Property rhs_thrust [string trim { |
|
\\\_ |
|
\@ > |
|
| ~ |
|
_- -_ |
|
\ \\ / |
|
// |
|
+_+_ |
|
} \n] |
|
|
|
>punk .. Property fossil [string trim { |
|
.. |
|
> < |
|
\ / v |
|
v \\_/ |
|
\/\\ v . |
|
v_ /|\/ / |
|
\__/ |
|
} \n] |
|
>punk .. Method deck {args} { |
|
#todo - themes? |
|
set this @this@ |
|
set RST [a] |
|
set punk_colour [a+ term-71] ;#term-darkseagreen4-b |
|
set hbar_colour [a+ web-silver] |
|
set vbar_colour [a+ web-steelblue] |
|
set border_colour [a+ web-lightslategray] |
|
set frame_type arc |
|
set punk $punk_colour[$this . lhs_air]$RST |
|
package require punk::args |
|
set standard_frame_types [textblock::frametypes] |
|
set argd [punk::args::get_dict [tstr -return string { |
|
@id -id ">punk . deck" |
|
@cmd -name "deck" -help "Punk Deck mascot" |
|
-frame -default arc -choices "${$standard_frame_types}" -choicerestricted 0 -choiceprefix 1 |
|
-boxmap -default {} -type dict |
|
-boxlimits -default {hl vl tlc blc trc brc} -help "Limit the border box to listed elements." |
|
-border_colour -default ${$border_colour} -type ansistring -regexprepass {^$} -validationtransform { |
|
-function stripansi -maxsize 0 |
|
} |
|
-title -default "PATTERN" -type string |
|
-subtitle -default "PUNK" -type string |
|
@values -max 0 |
|
}] $args] |
|
set frame_type [dict get $argd opts -frame] |
|
set box_map [dict get $argd opts -boxmap] |
|
set box_limits [dict get $argd opts -boxlimits] |
|
set border_colour [dict get $argd opts -border_colour] |
|
set title [dict get $argd opts -title] |
|
set subtitle [dict get $argd opts -subtitle] |
|
set punkdeck [overtype::right [overtype::left [textblock::frame -ansiborder $border_colour -type $frame_type -boxmap $box_map -boxlimits $box_limits -title $hbar_colour$title$RST -subtitle $hbar_colour$subtitle$RST $punk] "$vbar_colour\n\n\P\nU\nN\nK$RST"] "$vbar_colour\n\nD\nE\nC\nK"] |
|
} |
|
|
|
#TODO - reuse textblock::gcross arguments - but reorder for error display |
|
>punk .. Method gcross {{size 1} args} { |
|
package require textblock |
|
set argd [punk::args::get_by_id ::textblock::gcross [list {*}$args $size]] |
|
textblock::gcross {*}$args $size |
|
} |
|
|
|
>punk .. Method dumpProperties {{object ::>punk}} { |
|
set text "" |
|
foreach {p v} [$object .. Properties . pairs] { |
|
append text $p \n |
|
append text [set $v] \n \n |
|
} |
|
return $text |
|
} |
|
>punk .. Method listProperties {{object ::>punk}} { |
|
set result {} |
|
foreach {p v} [$object .. Properties . pairs] { |
|
lappend result $p [set $v] |
|
} |
|
return $result |
|
} |
|
|
|
|
|
########################################################## |
|
#CANDY-CODE |
|
# |
|
|
|
#Cute names for file I/O |
|
proc <- filename { |
|
set fp [open $filename] |
|
::patternpunk:lib::K [read $fp] [close $fp] |
|
} |
|
proc -> {filename string} { |
|
set fp [open $filename w] |
|
puts $fp $string |
|
close $fp |
|
} |
|
proc ->> {filename string} { |
|
set fp [open $filename a] |
|
puts $fp $string |
|
close $fp |
|
} |
|
|
|
#presumably this is to allow calling of standard objects using dotted notation? |
|
::>pattern .. Create ::> |
|
::> .. Method item {args} { |
|
#uplevel #0 $args |
|
#uplevel #0 [join $args] |
|
|
|
uplevel #0 $args |
|
} |
|
::> .. DefaultMethod item |
|
namespace eval patternpunk::lib { |
|
proc K {x y} {return $x} |
|
} |
|
package provide patternpunk [namespace eval patternpunk { |
|
variable version |
|
|
|
set version 1.1 |
|
}] |
|
#]]> |
|
#</code> |
|
#<files> |
|
#</files> |
|
#</xpack> |
|
#</xml> |
|
|
|
|