[Keith Vetter] 2010-09-10 -- Mormon Porn or Nude Bubbling was created by UltimusMormon on the BodyBuilding.com forum. He states "''Being mormon, I can't look at porn or nudity. So I have to get creative. That's why I invented 'bubbling' ''".

The basic idea is to take an image of a woman with lots of bare skin, create a bunch of 'bubbles' on top of the bare skin and turn that into an image mask where only the bubbles are transparent. The effect is that your imagination turns an innocent, albeit racy image into a seemingly nude, pornographic picture. You don't see any naughty bits, but your mind imagines them.

For more info check out http://nudebubbling.com/ and http://bubbler.heroku.com/index.html.

The fun for me was solving the technical challenges, like how to you create
transparent bubbles in a tk image? I had to write a primitive circle
drawing routing. Also, I wanted have the program to be more interactive, 
creating and displaying the mask in real time, but I couldn't get it 
done fast enough.

----

======
##+##########################################################################
#
# mormonPorn
# by Keith Vetter, Sept 8, 2010
#

package require Tk
package require Img
package require http

set S(fname) ""
set S(transparent) 0
set B1 {
    bubbleInside yellow
    bubbleEdge black
    mask yellow
    width 0
    width2 2
}
set B2 {
    bubbleInside {}
    bubbleEdge magenta
    mask yellow
    width 4
    width2 4
}

array set B $B1

proc DoDisplay {} {
    global S

    wm title . "Mormon Porn"
    bind all <F2> {console show}

    menu .m -tearoff 0
    . configure -menu .m
    menu .m.file -tearoff 0
    menu .m.bubble -tearoff 0
    menu .m.help -tearoff 0
    .m add cascade -label "File" -menu .m.file -underline 0
    .m add cascade -label "Bubble" -menu .m.bubble -underline 0
    .m add cascade -label "Help" -menu .m.help -underline 0

    .m.file add command -label "Restart" -command Restart -underline 0
    .m.file add command -label "Open File" -command "Open file" -under 0
    .m.file add command -label "Open URL" -command "Open url" -under 5
    .m.file add command -label "Save" -command "Save" -under 0
    .m.file add separator
    .m.file add command -label "Exit" -command exit -under 1

    .m.bubble add checkbutton -label "Transparent bubbles" \
        -underline 0 -variable ::S(transparent) -command ToggleTransparent

    .m.help add command -label "Demo" -command Demo -under 0
    .m.help add command -label "About" -command About -under 0

    ::ttk::frame .buttons
    ::ttk::button .mask -text "Make Mask" -command MakeMask

    ::ttk::frame .f -borderwidth 2 -relief ridge
    canvas .c -width 400 -height 600 -highlightthickness 0 -bd 0 -bg cyan
    bind .c <1> [list Button1 down %x %y]
    bind .c <B1-Motion> [list Button1 move %x %y]
    bind .c <ButtonRelease-1> [list Button1 up %x %y]
    bind .c <2> [list Button2 down %x %y]
    bind .c <B2-Motion> [list Button2 move %x %y]
    bind .c <ButtonRelease-2> [list Button2 up %x %y]
    bind .c <3> [list Button3 down %x %y]

    ::ttk::frame .f2 -borderwidth 2 -relief ridge
    canvas .c2 -width 400 -height 600 -highlightthickness 0 -bd 0 -bg cyan

    pack .buttons -side bottom -fill x
    pack .mask -in .buttons -side left -pady .2in -expand 1
    pack .f -side left -fill both -expand 1
    pack .c -in .f -side left -fill both -expand 1
    pack .f2 -side left -fill both -expand 1
    pack .c2 -in .f2 -side left -fill both -expand 1
}
##+##########################################################################
#
# NewBubbleImage -- Starts a new image to be bubbled
#
proc NewBubbleImage {fname} {
    global S BITMAP

    unset -nocomplain BITMAP
    foreach img [image names] { image delete $img }
    .c delete all
    .c2 delete all

    set img [NewImage $fname]
    set S(all) {}

    .c config -width $S(w) -height $S(h)
    .c2 config -width $S(w) -height $S(h)
    .c create image 0 0 -tag img -image $img -anchor nw
    .c2 create image 0 0 -tag img -image $img -anchor nw
}
##+##########################################################################
#
# Restart -- Erases all bubbles
#
proc Restart {} {
    global S

    .c delete bubble
    set S(all) {}
}
##+##########################################################################
#
# Open -- Gets new image filename or url
#
proc Open {what} {
    set fname [GetURLorFile $what]
    if {$fname eq ""} return
    NewBubbleImage $fname
}
##+##########################################################################
#
# Save -- Saves our bubble image
#
proc Save {} {
    set types {{"JPEG files" {.jpg}} {"All Files" *}}
    set fname [tk_getSaveFile -title "Mormon Porn Save File" \
                   -defaultextension .jpg \
                   -initialdir [file dirname $::S(fname)] \
                   -filetypes $types]
    if {$fname eq ""} return
    image create photo ::img::save
    ::img::save copy ::img::p
    if {"::img::mask" in [image names]} {
        ::img::save copy ::img::mask
    }
    ::img::save write $fname -format jpeg
    image delete ::img::save
    tk_messageBox -message "Saved $fname"
}
##+##########################################################################
#
# GetURLorFile -- Puts up either the stock getOpenFile dialog or custom
# getUrl dialog, and returns either the filename or url
#
proc GetURLorFile {what} {
    global S

    if {$what eq "file"} {
        set types {{"Image files" {.gif .jpg .png}} {"All Files" *}}
        set fname [tk_getOpenFile -title "Mormon Porn Open File" \
                       -initialdir [file dirname $S(fname)] \
                       -initialfile [file tail $S(fname)] \
                       -filetypes $types]
    } else {
        set save $::S(url)
        destroy .ux
        toplevel .ux
        wm title .ux "Mormon Porn Get URI"
        wm protocol .ux WM_DELETE_WINDOW {set ::S(url) ""; destroy .ux}

        set x [expr {[winfo x .] + 50}]
        set y [expr {[winfo y .] + 50}]
        wm geom .ux "+$x+$y"

        ::ttk::frame  .ux.u
        ::ttk::label  .ux.u.l -text "Enter URL"
        ::ttk::entry  .ux.u.e -textvariable ::S(url) -width 30
        ::ttk::frame .ux.u.buttons
        ::ttk::button .ux.u.buttons.go -text "Open" -command {destroy .ux}
        ::ttk::button .ux.u.buttons.cancel -text "Cancel" \
            -command {set ::S(url) ""; destroy .ux}

        pack .ux.u -fill both -expand 1 -padx .1in -pady {.1in 0}

        grid .ux.u.l -sticky w
        grid .ux.u.e -sticky ns
        grid .ux.u.buttons -pady .1in -sticky news
        pack .ux.u.buttons.go .ux.u.buttons.cancel  -side left -expand 1
        focus .ux.u.e
        .ux.u.e selection range 0 end
        .ux.u.e icursor end

        tkwait window .ux
        set fname $::S(url)
        if {$::S(url) eq ""} { set ::S(url) $save }
    }
    return $fname
}
##+##########################################################################
#
# MakeBubble -- Creates a bubble on the screen
#
proc MakeBubble {xy} {
    global B

    set tag [.c create oval $xy \
                 -fill $B(bubbleInside) \
                 -outline $B(bubbleEdge) \
                 -width $B(width) \
                 -tag bubble]
    return $tag
}
##+##########################################################################
#
# Button1 -- Handles creating and sizing a bubble
#
proc Button1 {verb x y} {
    global S B

    if {$verb eq "down"} {
        set S(cx) $x
        set S(cy) $y
        set xy [Box $x $y $x $y]

        set S(tag) [MakeBubble $xy]
    } elseif {$verb eq "move"} {
        set xy [Box $S(cx) $S(cy) $x $y]
        .c coords $S(tag) $xy
        set S(last) [list $x $y]
    } elseif {$verb eq "up"} {
        lappend S(all) [list $S(tag) $S(cx) $S(cy) $S(radius)]
    }
}
##+##########################################################################
#
# Button2 -- Handles dragging a bubble around the screen
#
proc Button2 {verb x y} {
    global S B

    if {$verb eq "down"} {
        set S(who) [FindBubble $x $y]
        if {$S(who) == -1} return

        set id [lindex $S(all) $S(who) 0]
        .c itemconfig $id -width $B(width2)
        .c config -cursor fleur
        set S(cx) $x
        set S(cy) $y

    } elseif {$verb eq "move"} {
        if {$S(who) == -1} return
        set dx [expr {$x - $S(cx)}]
        set dy [expr {$y - $S(cy)}]
        if {$dx == 0 && $dy == 0} return

        set id [lindex $S(all) $S(who) 0]
        .c move $id $dx $dy

        lassign [lindex $S(all) $S(who)] . cx cy
        incr cx $dx
        incr cy $dy

        set S(cx) $x
        set S(cy) $y
        lset S(all) $S(who) 1 $cx
        lset S(all) $S(who) 2 $cy
    } elseif {$verb eq "up"} {
        if {$S(who) == -1} return
        set id [lindex $S(all) $S(who) 0]
        .c itemconfig $id -width $B(width)
        .c config -cursor {}
    }
}
##+##########################################################################
#
# Button3 -- Handles deleting a bubble
#
proc Button3 {verb x y} {
    global S

    set idx [FindBubble $x $y]
    if {$idx == -1} return

    set id [lindex $S(all) $idx 0]
    .c delete $id
    set S(all) [lreplace $S(all) $idx $idx]
}
##+##########################################################################
#
# FindBubble -- Searches all bubbles in S(all) and return index of the last one
# which overlaps a given point
#
proc FindBubble {x y} {
    global S

    for {set i [expr {[llength $S(all)] - 1}]} {$i >= 0} {incr i -1} {
        lassign [lindex $S(all) $i] id cx cy radius
        if {hypot($cx-$x,$cy-$y) <= $radius} {
            return $i
        }
    }
    return -1
}
##+##########################################################################
#
# Box -- Given center and point on edge, returns bbox for our bubble
#
proc Box {cx cy x y} {
    set radius [expr {round(hypot($x-$cx,$y-$cy))}]
    if {$radius < 2} { set radius 2}
    set ::S(radius) $radius
    set x0 [expr {$cx-$radius}]
    set y0 [expr {$cy-$radius}]
    set x1 [expr {$cx+$radius}]
    set y1 [expr {$cy+$radius}]
    return [list $x0 $y0 $x1 $y1]
}
##+##########################################################################
#
# MakeMask -- Creates our bubble mask by hand drawing filled circles into
# an offscreen bitmap, then setting all empty bits to a mask color--leaving
# on bits undefined/transparent
#
proc MakeMask {{clr ""}} {
    global S BITMAP B

    unset -nocomplain BITMAP
    if {$clr eq ""} { set clr $B(mask) }
    foreach bubble $S(all) {
        MakeCircleMask {*}$bubble
    }

    set start [clock seconds]
    ::img::mask blank
    .c2 create image 0 0 -tag mask -image ::img::mask -anchor nw

    for {set y 0} {$y < $S(h)} {incr y} {
        set y1 [expr {$y+1}]
        update
        set off 1
        set BITMAP($S(w),$y) 1                  ;# Sentinel
        for {set x 0} {$x <= $S(w)} {incr x} {
            if {! [info exists BITMAP($x,$y)]} { ;# Pixel that needs masking
                if {$off} { set off 0; set left $x}
            } else {                            ;# Pixel that needs transparency
                if {! $off} {
                    set off 1
                    ::img::mask put $clr -to $left $y $x $y1
                }
            }
        }
        if {! $off} { puts "bad off: $y" ; return}
    }
    set end [clock seconds]
    puts "[expr {$end-$start}] seconds"
}
##+##########################################################################
#
# MakeCircleMask -- "Draws" a circle into a bitmap
# see http://www.cs.unc.edu/~mcmillan/comp136/Lecture7/circle.html
#
proc MakeCircleMask {tag cx cy r} {
    set x 0
    set y $r
    set p [expr {(5 - $r*4)/4.0}]

    _ExploitSymmetry $cx $cy $x $y
    while {$x < $y} {
        incr x
        if {$p < 0} {
            set p [expr {$p + 2*$x + 1}]
        } else {
            incr y -1
            set p [expr {$p + 2*($x-$y)+1}]
        }
        _ExploitSymmetry $cx $cy $x $y
    }
}
##+##########################################################################
#
# _ExploitSymmetry -- Uses symmetry to reflect known edge point around the circle
#
proc _ExploitSymmetry {cx cy x y} {
    if {$x == 0} {
        _Line [expr {$cx+$y}] $cy [expr {$cx-$y}] $cy
    } elseif {$x == $y} {
        _Line [expr {$cx + $x}] [expr {$cy + $y}] [expr {$cx - $x}] [expr {$cy + $y}]
        _Line [expr {$cx + $x}] [expr {$cy - $y}] [expr {$cx - $x}] [expr {$cy - $y}]
    } elseif {$x < $y} {
        _Line [expr {$cx + $x}] [expr {$cy + $y}] [expr {$cx - $x}] [expr {$cy + $y}]
        _Line [expr {$cx + $x}] [expr {$cy - $y}] [expr {$cx - $x}] [expr {$cy - $y}]
        _Line [expr {$cx + $y}] [expr {$cy + $x}] [expr {$cx - $y}] [expr {$cy + $x}]
        _Line [expr {$cx + $y}] [expr {$cy - $x}] [expr {$cx - $y}] [expr {$cy - $x}]
    }
}
##+##########################################################################
#
# _Line -- Fills in all bits on line between x0,y and x1,y
#
proc _Line {x0 y0 x1 y1} {
    global BITMAP S

    # ASSERTION: $y0 == $y1
    if {$y0 < 0 || $y0 >= $S(h)} return
    set lo [expr {max(min($x0,$x1),0)}]
    set hi [expr {min(max($x0,$x1),$S(w)-1)}]

    for {set x $lo} {$x <= $hi} {incr x} {
        set BITMAP($x,$y0) 1
    }
    #.c create line $x0 $y0 $x1 $y1 -fill cyan
}
##+##########################################################################
#
# Demo -- Does a quick demo using canned bubbles on a stock image
#
proc Demo {} {
    global demo
    set demo(who) [expr {($demo(who) + 1) % [llength [array names demo *,url]]}]

    if {$::S(proto) eq "http" && $::S(url) eq $demo($demo(who),url)} {
        Restart
    } else {
        NewBubbleImage $demo($demo(who),url)
    }
    foreach bubble $demo($demo(who),bubbles) {
        lassign $bubble tag cx cy r
        set x [expr {$cx + $r}]
        set y $cy
        set xy [Box $cx $cy $x $y]
        set tag [MakeBubble $xy]
        lappend ::S(all) [list $tag $cx $cy $::S(radius)]
    }
    MakeMask
}
##+##########################################################################
#
# About -- Our about and help dialog
#
proc About {} {
    destroy .about
    toplevel .about
    wm title .about "About Mormon Porn"
    wm geom .about "+[expr {[winfo x .] + [winfo width .] + 10}]+[winfo y .]"

    text .about.t -relief raised -wrap word -width 70 -height 24
    .about.t config -padx 10 -pady 10
    button .about.dismiss -text Dismiss -command {destroy .about}

    pack .about.dismiss -side bottom -pady 10
    pack .about.t -side top -expand 1 -fill both

    set bold "[font actual [.about.t cget -font]] -weight bold"
    set italic "[font actual [.about.t cget -font]] -slant italic"
    .about.t tag configure title -justify center -foreground red \
        -font "Times 20 bold"
    .about.t tag configure title2 -justify center -font "Times 12 bold"
    .about.t tag configure bold -font $bold
    .about.t tag configure quote -font $italic
    .about.t tag configure n -lmargin1 15 -lmargin2 15

    .about.t insert end "Mormon Porn / Nude Bubbling\n" title "by Keith Vetter\n\n" title2

    .about.t insert end "Mormon Porn was created by UltimusMormon "
    .about.t insert end "on the BodyBuilding.com forum. He states \""
    .about.t insert end "Being mormon, I can't look at porn or nudity. " quote
    .about.t insert end "So I have to get creative. That's why I " quote
    .about.t insert end "invented 'bubbling'" quote "\".\n\n"

    set msg "The basic idea is to take an image of a woman with "
    append msg "lots of bare skin, create a bunch of 'bubbles' "
    append msg "on top of the bare skin and turn that into an image mask where "
    append msg "only the bubbles are transparent.\n\n"
    .about.t insert end $msg

    set msg "The effect is that your imagination turns an innocent, "
    append msg "albeit racy image "
    append msg "into a seemingly nude, pornographic picture. "
    append msg "You don't see any naughty bits, but your mind imagines them.\n\n"
    .about.t insert end $msg

    .about.t insert end "For more info check out "
    .about.t insert end "http://nudebubbling.com/" bold " and "
    .about.t insert end "http://bubbler.heroku.com/index.html" bold ".\n\n"

    .about.t insert end "HOW TO USE\n" bold
    .about.t insert end "o" n " Create bubble: click and drag\n"
    .about.t insert end "o" n " Move bubble: click and drag middle button\n"
    .about.t insert end "o" n " Delete bubble: click right button\n"

    .about.t config -state disabled
}
##+##########################################################################
#
# NewImage -- Creates a new image from a filename or url
#
proc NewImage {fname} {
    global S

    if {[file exists $fname]} {
        set ::S(fname) $fname
        set ::S(proto) file
        set img [image create photo ::img::p -file $fname]
        set S(w) [image width $img]
        set S(h) [image height $img]
        image create photo ::img::mask -width $S(w) -height $S(h)

        return $img
    }
    if {[string match "http:*" $fname]} {
        set token [http::geturl $fname]
        ::http::wait $token
        set code [::http::code $token]
        set ncode [::http::ncode $token]
        set data [::http::data $token] ; list
        ::http::cleanup $token

        if {$ncode != 200} { error "Can't download $fname\n$code" }
        set n [catch { set img [image create photo ::img::p -data $data] } emsg]
        if {$n} {error "Not an image: $fname"}

        set ::S(url) $fname
        set ::S(proto) http
        set S(w) [image width $img]
        set S(h) [image height $img]
        image create photo ::img::mask -width $S(w) -height $S(h)
        return $img
    }
    error "can't find $fname"
}
##+##########################################################################
#
# ToggleTransparent -- As the name says
#
proc ToggleTransparent {} {
    global S B

    puts "S(transparent): $S(transparent)"
    if {$S(transparent)} {
        array set B $::B2
    } else {
        array set B $::B1
    }
    .c itemconfig bubble -width $B(width) -fill $B(bubbleInside) -outline $B(bubbleEdge)
}
################################################################

set demo(who) -1
set demo(0,url) {http://upload.wikimedia.org/wikipedia/commons/thumb/5/50/Lovely_model_-_Tricia_from_Singapore_-Bikini.jpg/400px-Lovely_model_-_Tricia_from_Singapore_-Bikini.jpg}
set demo(0,bubbles) {{bubble0 191 90 82} {bubble1 310 175 53} {bubble6 209 300 70} {bubble9 311 450 81} {bubble12 43 391 47} {bubble13 54 118 47} {bubble14 57 530 52} {bubble15 81 255 41} {bubble16 142 206 30} {bubble18 186 469 49}}
set demo(1,url) http://lh5.ggpht.com/_D8FfQDqFKYI/SsNN2pCfBvI/AAAAAAAAACs/Iw_Fo-JKkd4/s640/bikini_skirt01.jpg
set demo(1,bubbles) {{3 144 93 93} {4 277 165 50} {5 390 358 79} {6 154 435 79} {8 154 279 37} {9 36 282 49} {10 307 535 65}}
set demo(2,url) http://upload.wikimedia.org/wikipedia/commons/thumb/2/26/Christy_Marie_as_Slave_Leia.jpg/398px-Christy_Marie_as_Slave_Leia.jpg
set demo(2,bubbles) {{14 134 51 124} {15 332 169 70} {16 340 340 42} {19 207 418 61} {20 336 519 59} {21 80 546 64} {22 83 404 43} {23 101 220 43}}

DoDisplay
NewBubbleImage $demo(0,url)

return

======

----

<<categories>>Enter Category Here