# # # # # # 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 }] #]]> # # # # #