元ネタ

http://wiki.tcl.tk/11232

これは何をするものか?

GIMPのScript-Fuのリモート操作サーバをTclから操作するためのライブラリです。元ネタのソースが動かなくなっていたので、GIMP2.8日本語環境で動くようにしてパッケージ化したものです。

使い方

0.下記ダウンロードよりダウンロードしてlibディレクトリにライブラリを配置する。
1.GIMPを起動する。
2.Filter→Script-Fu→サーバースタート... からサーバを起動する。ポートはデフォルトの10008で。
これで準備OK。
3.tclsh
4.package require gimp
5.set gimp [gimp::connect]
6..以下色々な操作...

ソースコード

# Tcl client for Gimp's Script-Fu Server.
# Copyright(C) 2004 Salvatore Sanfilippo
#
# This is free software, under the terms of the GPL license version 2.
# You can get a copy of the license from http://www.gnu.org/copyleft/gpl.html
#
# TODO:
#
# - Define more constants
# - Write some decent example
# - Add some higher level subcommand with sane defaults
#   and options to specify more details, in the Tcl way.
package provide gimp 1.0

namespace eval gimp {}
namespace eval gimp::method {}

set gimp::debug 1

# GIMP constants

# Image type
set gimp::RGB     0
set gimp::GRAY    1
set gimp::INDEXED 2

# Layer type
set gimp::RGB_IMAGE      0
set gimp::RGBA_IMAGE     1
set gimp::GRAY_IMAGE     2
set gimp::GRAYA_IMAGE    3
set gimp::INDEXED_IMAGE  4
set gimp::INDEXEDA_IMAGE 5

# Layer mode
set gimp::NORMAL_MODE         0
set gimp::DISSOLVE_MODE       1
set gimp::BEHIND_MODE         2
set gimp::MULTIPLY_MODE       3
set gimp::SCREEN_MODE         4
set gimp::OVERLAY_MODE        5
set gimp::DIFFERENCE_MODE     6
set gimp::ADDITION_MODE       7
set gimp::SUBTRACT_MODE       8
set gimp::DARKEN_ONLY_MODE    9
set gimp::LIGHTEN_ONLY_MODE  10
set gimp::HUE_MODE           11
set gimp::SATURATION_MODE    12
set gimp::COLOR_MODE         13
set gimp::VALUE_MODE         14
set gimp::DIVIDE_MODE        15
set gimp::DODGE_MODE         16
set gimp::BURN_MODE          17
set gimp::HARDLIGHT_MODE     18
set gimp::SOFTLIGHT_MODE     19
set gimp::GRAIN_EXTRACT_MODE 20
set gimp::GRAIN_MERGE_MODE   21
set gimp::COLOR_ERASE_MODE   22



# Fill type
set gimp::FOREGROUND_FILL  0
set gimp::BACKGROUND_FILL  1
set gimp::WHITE_FILL       2
set gimp::TRANSPARENT_FILL 3
set gimp::PATTERN_FILL     4

# Units
set gimp::PIXELS 0
set gimp::POINTS 1

# Connect to a running GIMP (with Script-Fu Server enabled)
proc gimp::connect {{host 127.0.0.1} {port 10008}} {
    set fd [socket $host $port]
    fconfigure $fd -encoding binary -translation binary
    set handle "gimp-$fd"
    interp alias {} $handle {} gimp::request $fd
    set script {
(begin
    (define (scheme-list->tcl l)
      (let ((len (length l)) (i 0) (res ""))
        (set! res (string-append res "{"))
        (while (< i len)
          (set! res (string-append res (scheme->tcl (nth i l)) " "))
          (set! i (+ i 1)))
        (set! res (string-append res "}"))
        res))

    (define (scheme->tcl o)
      (cond
        ((pair? o) (scheme-list->tcl o))
        ((number? o) (number->string o))
        ((boolean? o) (if o "1" "0"))
        ((null? o) "{}")
        ((string? o) o)))

    (define (tclinterface-get-procedure-info procname)
        (let ((x (gimp-procedural-db-proc-info procname)) 
              (numargs 0) (numvals 0) (tclargs "") (tclvals "") (i 0))
            (begin
                (set! numargs (nth 6 x))
                (set! numvals (nth 7 x))
                 (while (< i numargs)
                    (let ((procinfo (gimp-procedural-db-proc-arg procname i)))
                        (set! tclargs (string-append tclargs
                            "{" (number->string (nth 0 procinfo)) " "
                                "{" (nth 1 procinfo) "}} ")))
                    (set! i (+ i 1)))
                (set! i 0)
                (while (< i numvals)
                    (let ((procinfo (gimp-procedural-db-proc-val procname i)))
                        (set! tclvals (string-append tclvals
                            "{" (number->string (nth 0 procinfo)) " "
                                "{" (nth 1 procinfo) "}} ")))
                    (set! i (+ i 1)))
                (string-append "{" tclargs "} {" tclvals "}")))))

    }
    set script [string map {\n " "} $script]
    ::gimp::evalscheme $fd $script
    return $handle
}

# Use the Script-Fu Server binary protocol to evaluate a Scheme s-expression.
proc gimp::evalscheme {fd script} {
    # Send the query...
    set script [string trim $script]
    set bin [encoding convertto utf-8 $script]
    if {$::gimp::debug} {puts "Script: $script"}
    set query "G[binary format S [string length $bin]]$bin"
    puts -nonewline $fd $query
    flush $fd
    # Get the reply...
    set hdr [read $fd 4]
    binary scan [string index $hdr 1] c errorcode
    binary scan [string range $hdr 2 3] S replylen
    if {$::gimp::debug} {
        puts "Reply error code: $errorcode len: $replylen"
    }
    set reply [encoding convertfrom utf-8 [read $fd $replylen]]
    if {$::gimp::debug} {
        puts "Reply: $reply"
    }
    if {$errorcode} {
        error "Script-Fu error '[string trim $reply]' executing '$script'"
    }
    return $reply
}

# Handle requests to Gimp handlers. Actually it's a dispatcher
# that calls the on-the-fly binding code if needed.
proc gimp::request {fd request args} {
    if {[catch {info args ::gimp::method::$request}]} {
        ::gimp::trytobind $fd $request
    }
    eval ::gimp::method::$request $fd $args
}

# Try to create bindings on-the-fly for the called Scheme function.
proc gimp::trytobind {fd funcname} {
    set pdbname [string map [list - _] $funcname]
    set scheme "(tclinterface-get-procedure-info \"$pdbname\")"
    if {[catch {::gimp::evalscheme $fd $scheme} result]} {
        # No PDB function with this name
        return
    } else {
        foreach {args vals} $result break
        set arglist fd
        set scheme "(scheme->tcl ($funcname "
        foreach a $args {
            foreach {type name} $a break
            append scheme "\[::gimp::tcl->scheme $type \${$name}\] "
            lappend arglist $name
        }
        append scheme "))"
        if {$::gimp::debug} {
            puts $scheme
        }
        if {[llength $vals] > 1} {
            proc ::gimp::method::$funcname $arglist [format {
                ::gimp::evalscheme $fd %s
            } "\"$scheme\""]
        } else {
            proc ::gimp::method::$funcname $arglist [format {
                lindex [::gimp::evalscheme $fd %s] 0
            } "\"$scheme\""]
        }
    }
}

# Convert Tcl PDB arguments to Scheme's equivalent
proc gimp::tcl->scheme {type val} {
    switch -- $type {
        0 - 1 - 2 - 3 {
            # Number and IDs
            return $val
        }
        5 - 6 - 7 - 8 - 9 - 10 {
            # Array of different types
            set res "'("
            foreach e $val {
                append res [switch $type {
                    5 - 6 - 7 - 8 - 10 {::gimp::tcl->scheme 0 $e}
                    9 {::gimp::tcl->scheme 4 $e}
                }] " "
            }
            append res ")"
        }
        4 {
            # String
            set q [list $val]
            if {[string length $q] != [string length $val]} {
                return "\"[string range $q 1 end-1]\""
            } else {
                return "\"$val\""
            }
        }
        default {
            # Id of images, layers, and so on.
            return $val
        }
    }
}

# Methods that does not have a counter-part in the Scheme environment

# Eval a scheme script
proc gimp::method::remote-eval {fd script} {
    ::gimp::evalscheme $fd $script
} 

# Close the link with Gimp and remove the alias
proc gimp::method::close fd {
    ::close $fd
    set handle "gimp-$fd"
    interp alias {} $handle {}
}

# Testing
proc gimp::example {} {
    set gimp [gimp::connect]
    set width 300
    set height 150
    set bgcolor [list 63 113 187]
    set textcolor [list 255 255 0]
    set img [$gimp gimp-image-new $width $height $gimp::RGB]
    set drawable [$gimp gimp-layer-new $img $width $height
    $gimp::RGB_IMAGE "FooLayer" 100 $gimp::NORMAL_MODE]
    $gimp gimp-image-undo-disable $img
    $gimp gimp-image-add-layer $img $drawable 0
    $gimp gimp-palette-set-foreground $textcolor
    $gimp gimp-palette-set-background $bgcolor
    $gimp gimp-edit-fill $drawable $gimp::BACKGROUND_FILL
    $gimp gimp-drawable-update $drawable 0 0 $width $height
    $gimp gimp-text-fontname $img $drawable 10 10 "Tcl+Gimp=Fun" 0 1 30
    $gimp::PIXELS "Verdana"
    $gimp gimp-display-new $img
    $gimp gimp-image-undo-enable $img
    $gimp close
}

#gimp::example

サンプルコード

とくにありません。gimp::exampleを実行してみてください。

ダウンロード

http://reddog.s35.xrea.com/software/tcl-gimp.zip

コメントをどーぞ



CategoryTclTk


|New|Edit|Freeze|Diff|Backup|Upload|Copy|Rename|
Last-modified: 2016-12-22 (Thu) 22:21:18 (95d)
HTML convert time: 0.010 sec.