punkshell/src/modules/patternpunk-1.1.tm

#<?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
pattern::init

package provide patternpunk  [namespace eval punk {
	variable version 

	set version 1.1
}]


::>pattern .. Create ::>punk
::>punk .. Property license {Public Domain}
::>punk .. Property logo2 {
+-----------------------+
|     Pattern PUNK      |
|   .      \\\_     .   |
|  .*.     \@  >   .=.  |
| .*.*.     | ~   .=.=. |
|.*.*.*.\_-   -_/.=.=.=.|
| .*.*.     \\    .=.=. |
|  .*.      / \    .=.  |
|   .     _+   +_   .   |
+-----------------------+
}
set ::punk::bannerTemplate {
+-----------------------+
|   .000000000000000.   |
|  .*.     \\\_    .=.  |
| .*.*.    \@  >  .=.=. |
|.*.*.*.    | ~  .=.=.=.|
| .*.*. \_-   -_/ .=.=. |
|  .*.      \\     .=.  |
|   .       / \     .   |
|111111111_+   +_2222222|
+-----------------------+
}

>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 logo 			[>punk . banner]
>punk .. Property versionLogo 	[>punk . banner -left "  Ver" -right "$::punk::version  "]
>punk .. Property version		$::punk::version

>punk .. Property front {
      _|_   
     @ v @  
       ~    
     -   -  
    |_\ /_| 
      / \   
    _+   +_ 
}
>punk .. Property back {
       |   
     ( | ) 
       |   
     -   - 
    |_\ /_|
      / \  
    _-   -_
}
>punk .. Property rhs {
     \\\_   
     \@  >  
      | ~   
  \_-   -_  
      \\ /  
      / \   
    _+   +_ 
}
>punk .. Property right
>punk .. PropertyRead right {} {
	return $o_rhs
}


>punk .. Property lhs {
      _///   
     <  @/   
      ~ |    
     _-   -_/
     \ //    
      / \    
    _+   +_  
}
>punk .. Property left
>punk .. PropertyRead left {} {
	return $o_lhs
}

>punk .. Property rhs_air {
     \\\_   
     \@  >  
      | ~   
  \_-   -_/  
      \\   
      / \   
    _+   +_   
}
>punk .. Property lhs_air {
      _///   
     <  @/   
      ~ |    
    \_-   -_/
       //    
      / \    
    _+   +_  
}

>punk .. Property lhs_hips {
      _///   
     <  @/   
      ~ |    
    _-   -_
    \ | | /  
      / \    
    _+   +_  
}
>punk .. Property rhs_hips {
     \\\_   
     \@  >  
      | ~   
    _-   -_  
    \ | | /
      / \   
    _+   +_ 
}


>punk .. Property piss {
     \\\_   
     \@  >  
      | ~   
  \_-   -_/  
      \\_ ..  
      / \   ..
    _+   +_   .
}

>punk .. Property poop {
    _///   
   <  @/   
    ^ |   
   _-   -_
    \ \\ /  
      //. ~   
    _+_+ @ 
}

>punk .. Method dumpProperties {{object ::>punk}} {
	foreach {p v} [$object .. Properties . pairs] {
		puts $p
		puts [set $v]
		puts \n
	}
}
>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]
    ::pattern::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

#]]>
#</code>
#<files>
#</files>
#</xpack>
#</xml>