Clothe 2D stick figure

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Clothe 2D stick figure

Postby BasicCoder2 » Mar 13, 2018 22:11

This gives an idea how images might be used to cloth the rigging in a 2D figure.
To keep it short I have not implemented all the BONE types variables in this demo nor have I implemented branching bones.
Multiput rotates around the center of an image.
I made use of multiput scaling with variable mag to change the length and size of images.

You must right click and save the two images and resave in the same folder as the program under the names arm1.bmp and arm2.bmp
Image
Image
Image

save this source code as multiput.bi

Code: Select all

' by D.J.Peters (Joshy)
' an put, scale, rotate hackfor the new ImageHeader format.
' MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]

'#define UseRad 'if not then Rotate are in degres

Sub MultiPut(Byval lpTarget As Any Ptr= 0, _
             Byval xMidPos  As Integer= 0, _
             Byval yMidPos  As Integer= 0, _
             Byval lpSource As Any Ptr   , _
             Byval xScale   As Single = 1, _
             Byval yScale   As Single = 1, _
             Byval Rotate   As Single = 0, _
             Byval Trans    As Integer= 0)

  If (screenptr=0) Or (lpSource=0) Then Exit Sub

  If xScale < 0.001 Then xScale=0.001
  If yScale < 0.001 Then yScale=0.001

  Dim As Integer MustLock,MustRotate

  If lpTarget= 0 Then MustLock  =1
  If Rotate  <>0 Then MustRotate=1

  Dim as Integer  TargetWidth,TargetHeight,TargetBytes,TargetPitch
  If MustLock Then
    ScreenInfo    _
    TargetWidth , _
    TargetHeight, _
    TargetBytes ,,_
    TargetPitch
    TargetBytes shr=3

    lpTarget=ScreenPtr
  Else
    TargetBytes  = cptr(uinteger Ptr,lpTarget)[1]
    TargetWidth  = cptr(uinteger Ptr,lpTarget)[2]
    TargetHeight = cptr(uinteger Ptr,lpTarget)[3]
    TargetPitch  = cptr(uinteger Ptr,lpTarget)[4]
    lpTarget    += 32
  End If
  If (TargetWidth<4) Or (TargetHeight<4) Then Exit Sub

  Dim As Integer   SourceWidth,SourceHeight,SourceBytes,SourcePitch
  if cptr(integer Ptr,lpSource)[0] = 7 then
    SourceBytes  = cptr(uinteger Ptr,lpSource)[1]
    SourceWidth  = cptr(uinteger Ptr,lpSource)[2]
    SourceHeight = cptr(uinteger Ptr,lpSource)[3]
    SourcePitch  = cptr(uinteger Ptr,lpSource)[4]
    lpSource    += 32
  else
    SourceBytes  = 1
    SourceWidth  = cptr(ushort Ptr,lpSource)[0] shr 3
    SourceHeight = cptr(ushort Ptr,lpSource)[1]
    SourcePitch  = SourceWidth
    lpSource    += 4
  end if
#if 0
  ? TargetWidth & "x" & TargetHeight & "x" & TargetBytes,TargetPitch
  ? SourceWidth & "x" & SourceHeight & "x" & SourceBytes,SourcePitch
  ? MustLock,Trans
  sleep:end
#endif

  If (SourceWidth<2) Or (SourceHeight<2) Then Exit Sub
  If (TargetBytes<>SourceBytes) Then Exit Sub

#define xs 0 'screen
#define ys 1
#define xt 2 'texture
#define yt 3
  Dim As Single Points(3,3)
  points(0,xs)=-SourceWidth/2 * xScale
  points(1,xs)= SourceWidth/2 * xScale
  points(2,xs)= points(1,xs)
  points(3,xs)= points(0,xs)

  points(0,ys)=-SourceHeight/2 * yScale
  points(1,ys)= points(0,ys)
  points(2,ys)= SourceHeight/2 * yScale
  points(3,ys)= points(2,ys)

  points(1,xt)= SourceWidth-1
  points(2,xt)= points(1,xt)
  points(2,yt)= SourceHeight-1
  points(3,yt)= points(2,yt)

  Dim As Uinteger i
  Dim As Single x,y
  If MustRotate Then
    #ifndef UseRad
    Rotate*=0.017453292 'degre 2 rad
    #endif
    While Rotate< 0        :rotate+=6.2831853:Wend
    While Rotate>=6.2831853:rotate-=6.2831853:Wend
    For i=0 To 3
      x=points(i,xs)*Cos(Rotate) - points(i,ys)*Sin(Rotate)
      y=points(i,xs)*Sin(Rotate) + points(i,ys)*Cos(Rotate)
      points(i,xs)=x:points(i,ys)=y
    Next
  End If

  Dim As Integer yStart,yEnd,xStart,xEnd
  yStart=100000:yEnd=-yStart:xStart=yStart:xEnd=yEnd

#define LI 0   'LeftIndex
#define RI 1   'RightIndex
#define  IND 0 'Index
#define NIND 1 'NextIndex
  Dim As Integer CNS(1,1) 'Counters

  For i=0 To 3
    points(i,xs)=Int(points(i,xs)+xMidPos)
    points(i,ys)=Int(points(i,ys)+yMidPos)
    If points(i,ys)<yStart Then yStart=points(i,ys):CNS(LI,IND)=i
    If points(i,ys)>yEnd   Then yEnd  =points(i,ys)
    If points(i,xs)<xStart Then xStart=points(i,xs)
    If points(i,xs)>xEnd   Then xEnd  =points(i,xs)
  Next
  If yStart =yEnd         Then Exit Sub
  If yStart>=TargetHeight Then Exit Sub
  If yEnd   <0            Then Exit Sub
  If xStart = xEnd        Then Exit Sub
  If xStart>=TargetWidth  Then Exit Sub
  If xEnd   <0            Then Exit Sub

  Dim As uByte    Ptr t1,s1
  Dim As uShort   Ptr t2,s2
  Dim As uInteger Ptr t4,s4


#define ADD 0
#define CMP 1
#define SET 2
  Dim As Integer ACS(1,2) 'add compare and set
  ACS(LI,ADD)=-1:ACS(LI,CMP)=-1:ACS(LI,SET)=3
  ACS(RI,ADD)= 1:ACS(RI,CMP)= 4:ACS(RI,SET)=0

#define EX  0
#define EU  1
#define EV  2
#define EXS 3
#define EUS 4
#define EVS 5
  Dim As Single E(2,6),S(6),Length,uSlope,vSlope
  Dim As Integer U,UV,UA,UN,V,VV,VA,VN

  ' share the same highest point
  CNS(RI,IND)=CNS(LI,IND)
  If MustLock Then ScreenLock
  ' loop from Top to Bottom
  While yStart<yEnd
    'Scan Left and Right sides together
    For i=LI To RI
      ' bad to read but fast and short ;-)
      If yStart=points(CNS(i,IND),ys) Then
        CNS(i,NIND)=CNS(i,IND)+ACS(i,Add)
        If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
        While points(CNS(i,IND),ys) = points(CNS(i,NIND),ys)
          CNS(i, IND)=CNS(i,NIND)
          CNS(i,NIND)=CNS(i, IND)+ACS(i,Add)
          If CNS(i,NIND)=ACS(i,CMP) Then CNS(i,NIND)=ACS(i,SET)
        Wend
        E(i,EX) = points(CNS(i, IND),xs)
        E(i,EU) = points(CNS(i, IND),xt)
        E(i,EV) = points(CNS(i, IND),yt)
        Length  = points(CNS(i,NIND),ys)
        Length -= points(CNS(i, IND),ys)
        If Length <> 0.0 Then
          E(i,EXS) = points(CNS(i, NIND),xs)-E(i,EX):E(i,EXS)/=Length
          E(i,EUS) = points(CNS(i, NIND),xt)-E(i,EU):E(i,EUS)/=Length
          E(i,EVS) = points(CNS(i, NIND),yt)-E(i,EV):E(i,EVS)/=Length
        End If
        CNS(i,IND)=CNS(i,NIND)
      End If
    Next

    If (yStart<0)                              Then Goto SkipScanLine
    xStart=E(LI,EX)+0.5:If xStart>=TargetWidth Then Goto SkipScanLine
    xEnd  =E(RI,EX)-0.5:If xEnd  < 0           Then Goto SkipScanLine
    If (xStart=xEnd)                           Then Goto SkipScanLine
    'if xEnd  <xStart                           then goto SkipScanLine
    Length=xEnd-xStart
    uSlope=E(RI,EU)-E(LI,EU):uSlope/=Length
    vSlope=E(RI,EV)-E(LI,EV):vSlope/=Length
    If xstart<0 Then
      Length=Abs(xStart)
      U=Int(E(LI,EU)+uSlope*Length)
      V=Int(E(LI,EV)+vSlope*Length)
      xStart = 0
    Else
      U=Int(E(LI,EU)):V=Int(E(LI,EV))
    End If
    If xEnd>=TargetWidth Then xEnd=TargetWidth-1
    UV=Int(uSlope):UA=(uSlope-UV)*100000:UN=0
    VV=Int(vSlope):VA=(vSlope-VV)*100000:VN=0
    xEnd-=xStart
    Select Case TargetBytes
      Case 1
        t1=cptr(ubyte ptr,lpTarget)
        t1+=yStart*TargetPitch+xStart:xStart=0
        If Trans=0 Then
          While xStart<xEnd
            s1=lpSource+V*SourcePitch+U
            *t1=*s1
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t1+=1
          Wend
        Else
          While xStart<xEnd
            s1=lpSource+V*SourcePitch+U
            If *s1 Then *t1=*s1
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t1+=1
          Wend
        End If
      Case 2
        t2=cptr(Short Ptr,lpTarget)
        t2+=yStart*(TargetPitch shr 1)+xStart:xStart=0
        If Trans=0 Then
          While xStart<xEnd
            s2=cptr(Short Ptr,lpSource)+V*(SourcePitch shr 1)+U
            *t2=*s2
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t2+=1
          Wend
        Else
          While xStart<xEnd
            s2=cptr(Short Ptr,lpSource)+V*(SourcePitch shr 1)+U
            If *s2<>&HF81F Then *t2=*s2
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t2+=1
          Wend
        End If
      Case 4
        t4=cptr(Integer Ptr,lpTarget)+yStart*(TargetPitch shr 2)+xStart:xStart=0
        If Trans=0 Then
          While xStart<xEnd
            s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch shr 2)+U
            *t4=*s4
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t4+=1
          Wend
        Else
          While xStart<xEnd
            's4=cptr(Integer Ptr,lpSource):s4+=V*(SourcePitch shr 2):s4+=U
            s4=cptr(Integer Ptr,lpSource)+V*(SourcePitch shr 2)+U
            If *s4<>&HFFFF00FF Then *t4=*s4
            U+=UV:UN+=UA:If UN>=100000 Then U+=1:UN-=100000
            V+=VV:VN+=VA:If VN>=100000 Then V+=1:VN-=100000
            If u<0 Then u=0
            If v<0 Then v=0
            xStart+=1:t4+=1
          Wend
        End If
    End Select

SkipScanLine:
    E(LI,EX)+=E(LI,EXS):E(LI,EU)+=E(LI,EUS):E(LI,EV)+=E(LI,EVS)
    E(RI,EX)+=E(RI,EXS):E(RI,EU)+=E(RI,EUS):E(RI,EV)+=E(RI,EVS)
    yStart+=1:If yStart=TargetHeight Then yStart=yEnd 'exit loop
  Wend
If MustLock Then ScreenUnlock
End Sub


Demo

Code: Select all

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

sub drawLine(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,size As Integer,c As ulong)
  var dx = x2 - x1
  var dy = y2 - y1
  if dx = 0 andalso dy=0 then
    circle (x1, y1), size, c, , , , f       
  elseif abs(dx) > abs(dy) then
    var m = dy / dx
    for x as Integer = x1 To x2 step sgn(dx)
      circle (x,m * (x - x1) + y1), size, c, , , , f
    next
  else
    var m =dx / dy
    for y as Integer = y1 To y2 step sgn(dy)
      circle (m * (y - y1) + x1,y), size, c, , , ,f
    next
  end if
end sub

#include "multiput.bi"
'MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]

const SCRW = 800
const SCRH = 600
screenres SCRW,SCRH,32

dim shared as any ptr img1,img2,torso
img1 = imagecreate(391,43,rgb(255,0,255))
bload "arm1.bmp",img1
img2 = imagecreate(391,43,rgb(255,0,255))
bload "arm2.bmp",img2
torso = imagecreate(113,353)
bload "torso.bmp",torso

type BONE
    as integer x1      'absolute start
    as integer y1
    as integer x2      'end  point
    as integer y2
    as single  a       'angle of joint
    as single  aMin    'limits of joint movement
    as single  aMax
    as single  s       'size
    as any ptr img     'image
end type

dim shared as BONE arm1,arm2

arm1.x1 = SCRW\2  'starting point
arm1.y1 = SCRH\2

arm1.s  = 185   'length
arm2.s  = 185
arm1.aMin = 36  'set rotation limits
arm1.aMax = 227
arm2.aMin = 0
arm2.aMax = 141

arm1.a  = 90    'starting angles must be between rotational limits
arm2.a  = 100


dim as single angle
dim as single mag     'magnification
mag = 0.5



do

    screenlock
    cls
   
    multiput 0,arm1.x1,arm1.y1,torso,mag,mag,0,1  'draw torso
   
    angle = arm1.a
    if angle < 0   then angle = angle + 360
    if angle > 359 then angle = angle - 360
    arm1.x2 = arm1.x1 + cos(angle*DtoR) * arm1.s * mag
    arm1.y2 = arm1.y1 + sin(angle*DtoR) * arm1.s * mag
    multiput 0,arm1.x1,arm1.y1,img1,mag,mag,angle,1
    drawLine (arm1.x1,arm1.y1,arm1.x2,arm1.y2,3,rgb(255,0,0))
    'line (arm1.x1,arm1.y1)-(arm1.x2,arm1.y2),rgb(255,0,0)
   
    arm2.x1 = arm1.x2
    arm2.y1 = arm1.y2
    angle = arm1.a + arm2.a  'add next angle
    if arm2.a < 0   then arm2.a = arm2.a + 360
    if arm2.a > 359 then arm2.a = arm2.a - 360
    arm2.x2 = arm2.x1 + cos(angle*DtoR) * arm2.s * mag
    arm2.y2 = arm2.y1 + sin(angle*DtoR) * arm2.s * mag
    multiput 0,arm2.x1,arm2.y1,img2,mag,mag,angle,1
    line (arm2.x1,arm2.y1)-(arm2.x2,arm2.y2),rgb(0,255,0)
   
    locate 2,1
    print " arm1.a =";arm1.a
    print " arm2.a =";arm2.a
    print " Use arrow keys"
    screenunlock

    if multikey(&H4B) then 'MOVE LEFT
        arm1.a = arm1.a + 1
        if arm1.a > 359 then arm1.a = arm1.a - 360
    end if
       
    if multikey(&H4D) then 'MOVE RIGHT
        arm1.a =  arm1.a - 1
        if arm1.a < 0 then arm1.a = arm1.a + 360
    end if

    if multikey(&H48) then 'MOVE UP
        arm2.a = arm2.a + 1
        if arm2.a > 359 then arm2.a = arm2.a - 360
    end if
       
    if multikey(&H50) then 'MOVE DOWN
        arm2.a = arm2.a - 1
        if arm2.a < 0 then arm2.a = arm2.a + 360
    end if
   
    'adjust for limits
    if arm1.a < arm1.aMin then arm1.a = arm1.aMin
    if arm1.a > arm1.aMax then arm1.a = arm1.aMax
    if arm2.a < arm2.aMin then arm2.a = arm2.aMin
    if arm2.a > arm2.aMax then arm2.a = arm2.aMax
   
    sleep 2
loop until multikey(&H01)

imagedestroy(img1)
imagedestroy(img2)
imagedestroy(torso)

Last edited by BasicCoder2 on Mar 18, 2018 23:41, edited 1 time in total.
nimdays
Posts: 236
Joined: May 29, 2014 22:01
Location: ID

Re: Cloth 2D stick figure

Postby nimdays » Mar 15, 2018 0:50

My isp is blocking imgur, Do you have any alternatives?
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Clothe 2D stick figure

Postby BasicCoder2 » Mar 15, 2018 1:24

@nimdays,
Do they show up as images in the forum post?
If so there is always the print screen key then fire up PAINT and PASTE. Then cut out the images.
Otherwise run the program below to make and save some similar images.
The images are a bit rubbish it was only to show how using multiput you could overlay an image on the line segments of a stick figure.

Code: Select all

screenres 640,480,32
dim as any ptr arm1,arm2,torso
arm1 = imagecreate(391,43,rgb(255,0,255))
arm2 = imagecreate(391,43,rgb(255,0,255))
torso = imagecreate(113,352,rgb(255,0,255))

line arm1,(178,6)-(391,38),rgb(255,127,0),bf
line arm1,(178,6)-(391,38),rgb(0,0,0),b
circle arm1,(195,22),5,rgb(255,255,255),,,,f
circle arm1,(195,22),5,rgb(0,0,0)
circle arm1,(372,22),5,rgb(255,255,255),,,,f
circle arm1,(372,22),5,rgb(0,0,0)

line arm2,(177,6)-(305,38),rgb(255,127,0),bf
line arm2,(177,6)-(305,38),rgb(0,0,0),b
line arm2,(306,0)-(346,38),rgb(255,127,0),bf
line arm2,(306,0)-(346,42),rgb(0,0,0),b

for i as integer = 0 to 2
   line arm2,(347,i*14)-(391,i*14+14),rgb(255,127,0),bf
   line arm2,(347,i*14)-(391,i*14+14),rgb(0,0,0),b
next i


line torso,(0,100)-(113,352),rgb(10,255,10),bf
line torso,(0,100)-(113,352),rgb(0,0,0),b

put (0,0),arm1,pset
put (0,100),arm2,pset
put (400,0),torso,pset

bsave "arm1.bmp",arm1
bsave "arm2.bmp",arm2
bsave "torso.bmp",torso

sleep
Last edited by BasicCoder2 on Mar 18, 2018 23:42, edited 3 times in total.
lizard
Posts: 440
Joined: Oct 17, 2017 11:35
Location: Germany

Re: Cloth 2D stick figure

Postby lizard » Mar 15, 2018 3:47

In this case it would be easier to use glyph-strings, then it would be possiible to post all as one listing.
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Clothe 2D stick figure

Postby BasicCoder2 » Mar 15, 2018 18:54

@lizard,
There was a thread on inserting images in the source code as data statements or as a string.
viewtopic.php?f=15&t=25440&hilit=images
Last edited by BasicCoder2 on Mar 18, 2018 23:42, edited 1 time in total.
sancho3
Posts: 358
Joined: Sep 30, 2017 3:22

Re: Cloth 2D stick figure

Postby sancho3 » Mar 16, 2018 3:30

nimdays wrote:My isp is blocking imgur, Do you have any alternatives?

I can't imagine why your ISP would be blocking imgur. Its the most innocuous site out there. There aren't even a ton of ads on it.
But if that is the case then maybe it would be best if you google searched an image hoster that your ISP isn't blocking.
How about Flickr?
Here is a top ten list
nimdays
Posts: 236
Joined: May 29, 2014 22:01
Location: ID

Re: Cloth 2D stick figure

Postby nimdays » Mar 16, 2018 4:10

sancho3 wrote:I can't imagine why your ISP would be blocking imgur. Its the most innocuous site out there. There aren't even a ton of ads on it.
But if that is the case then maybe it would be best if you google searched an image hoster that your ISP isn't blocking.
How about Flickr?
Here is a top ten list

Vimeo, Reddit and Imgur are blocked in Indonesia.Thanks for the list.

@BasicCoder2,Looks great.
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Clothe 2D stick figure

Postby BasicCoder2 » Mar 16, 2018 20:18

nimdays wrote:Vimeo, Reddit and Imgur are blocked in Indonesia.Thanks for the list.
@BasicCoder2,Looks great.

A pity they are blocked do you know why?
Imgur was easy to use the others look complicated.
I have written a full side version of the clothed stickman but no point posting without images.
I will try and find time to write a program to generate the images.
.
Last edited by BasicCoder2 on Mar 18, 2018 23:42, edited 1 time in total.
Boromir
Posts: 451
Joined: Apr 30, 2015 19:28
Location: Texas,U.S., Earth,Solar System
Contact:

Re: Cloth 2D stick figure

Postby Boromir » Mar 17, 2018 17:40

BasicCoder2 wrote:Imgur was easy to use the others look complicated.

This one is simple.
https://postimages.org/

BasicCoder2 wrote:A pity they are blocked do you know why?

Indonesian laws. In Indonesia the government controls most of DNS servers so they can block sites that don't conform to their laws.
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Clothe 2D stick figure

Postby BasicCoder2 » Mar 18, 2018 7:24

@Boromir,
Loaded these images to your suggested site.
Are they blocked in Indonesia?

Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image

The above images have to be resaved as bitmaps.
I guess I need to find a fb library to load a .png file.


Code: Select all

#include "multiput.bi"
'MultiPut [destination],[xmidpos],[ymidpos],source,[xScale],[yScale],[Trans]

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

sub drawLine(x1 As Integer,y1 As Integer,x2 As Integer,y2 As Integer,size As Integer,c As ulong)
  var dx = x2 - x1
  var dy = y2 - y1
  if dx = 0 andalso dy=0 then
    circle (x1, y1), size, c, , , , f       
  elseif abs(dx) > abs(dy) then
    var m = dy / dx
    for x as Integer = x1 To x2 step sgn(dx)
      circle (x,m * (x - x1) + y1), size, c, , , , f
    next
  else
    var m =dx / dy
    for y as Integer = y1 To y2 step sgn(dy)
      circle (m * (y - y1) + x1,y), size, c, , , ,f
    next
  end if
end sub

screenres 640,480,32
'color rgb(0,0,0),rgb(255,255,255):cls

'CREATE AND LOAD IMAGES
'pointers to images
dim as any ptr head,kneck
dim as any ptr upperArmLeft,lowerArmLeft,leftHand
dim as any ptr upperArmRight,lowerArmRight,rightHand
dim as any ptr torso
dim as any ptr upperLegLeft,lowerLegLeft,leftShoe
dim as any ptr upperLegRight,lowerLegRight,rightShoe
'create bitmaps for each pointer to point to
head = imagecreate(37,46)
kneck = imagecreate(69,23)
upperArmLeft = imagecreate(133,23)
lowerArmLeft = imagecreate(95,17)
leftHand = imagecreate(53,19)
upperArmRight = imagecreate(133,23)
lowerArmRight = imagecreate(95,17)
rightHand = imagecreate(53,19)
torso = imagecreate(191,33)
upperLegLeft = imagecreate(189,33)
lowerLegLeft = imagecreate(165,23)
leftShoe = imagecreate(63,17)
upperLegRight = imagecreate(189,33)
lowerLegRight = imagecreate(165,23)
rightShoe = imagecreate(63,17)
'load images into bitmaps
bload "head.bmp",head
bload "kneck.bmp",kneck
bload "upperArmLeft.bmp",upperArmLeft
bload "lowerArmLeft.bmp",lowerArmLeft
bload "leftHand.bmp",leftHand
bload "upperArmRight.bmp",upperArmRight
bload "lowerArmRight.bmp",lowerArmRIght
bload "rightHand.bmp",rightHand
bload "torso.bmp",torso
bload "upperLegLeft.bmp",upperLegLeft
bload "lowerLegLeft.bmp",lowerLegLeft
bload "leftShoe.bmp",leftShoe
bload "upperLegRight.bmp",upperLegRight
bload "lowerLegRight.bmp",lowerLegRight
bload "rightShoe.bmp",rightShoe

dim shared as integer selected   'selected bone number
selected = 1                     'first bone as bone(0) is a dummy
dim shared as single mag         'magnification of image
mag = 1

type BONE
    as integer r       'reset start angle
    as integer p       'pointer to previous bone
    as integer x1      'absolute start
    as integer y1
    as integer x2      'end  point
    as integer y2
    as single  a       'angle of joint
    as single  a2      'save computed angles
    as single  aMin    'limits of joint movement
    as single  aMax
    as single  s       'size
    as ulong   c       'color
    as any ptr img
end type

dim shared as BONE bones(0 to 15)
'order in which to draw components for overlap
dim shared as integer Order(1 to 15)
for i as integer = 1 to 15
    read order(i)
next i


'=================== LEG 1 ================
bones(0).x2 = 320   'start point
bones(0).y2 = 240

bones(1).r = 1

bones(1).a = 53
bones(2).a = 53
bones(3).a = 239

bones(1).s = 85
bones(2).s = 75
bones(3).s = 31

bones(1).c = rgb(255,0,0)
bones(2).c = rgb(255,0,0)
bones(3).c = rgb(255,0,0)

bones(1).p = 0
bones(2).p = 1
bones(3).p = 2

bones(1).img = upperLegLeft
bones(2).img = lowerLegLeft
bones(3).img = leftShoe

'==================== LEG 2 =====================
bones(4).r = 1

bones(4).a = 90 '59
bones(5).a = 53
bones(6).a = 239

bones(4).s = 85
bones(5).s = 75
bones(6).s = 31

bones(4).c = rgb(0,255,0)
bones(5).c = rgb(0,255,0)
bones(6).c = rgb(0,255,0)

bones(4).p = 0
bones(5).p = 4
bones(6).p = 5

bones(4).img = upperLegRight
bones(5).img = lowerLegRight
bones(6).img = rightShoe

'===================== TORSO ========================

bones(7).r = 1
bones(7).a = 270
bones(7).s = 85
bones(7).c = rgb(0,0,255)
bones(7).p = 0

bones(7).img = torso

'===================== ARM 1 =========================

bones(8).r = 1

bones(8).a = 81
bones(9).a = 294
bones(10).a = 33

bones(8).s = 59
bones(9).s = 42
bones(10).s = 27

bones(8).c = rgb(0,255,255)
bones(9).c = rgb(0,255,255)
bones(10).c = rgb(0,255,255)

bones(8).p = 7
bones(9).p = 8
bones(10).p = 9

bones(8).img = upperArmLeft
bones(9).img = lowerArmLeft
bones(10).img = leftHand


'===================== ARM 2 =========================

bones(11).r = 1

bones(11).a = 135
bones(12).a = 343
bones(13).a = 320

bones(11).s = 59
bones(12).s = 42
bones(13).s = 27

bones(11).c = rgb(155,155,0)
bones(12).c = rgb(155,155,0)
bones(13).c = rgb(155,155,0)

bones(11).p = 7
bones(12).p = 11
bones(13).p = 12

bones(11).img = upperArmRight
bones(12).img = lowerArmRight
bones(13).img = rightHand

'==================  KNECK AND HEAD ====================

bones(14).r = 1
bones(14).a = 270
bones(14).s = 29
bones(14).c = rgb(200,0,200)
bones(14).p = 7
bones(14).img = kneck

bones(15).a = 90
bones(15).s = 18
bones(15).c = rgb(100,30,100)
bones(15).p = 14
bones(15).img = head



dim shared as single angle

sub drawBones()
    color rgb(255,255,255)
    screenlock
    cls
    locate 2,1
    print " Tap space bar to move through pivot points"
    print
    print " You can select front pivots by clicking them with left mouse button"
    print
    print " Use left/right arrow keys OR keys [A] and [D] to rotate selected pivot"
   
    'compute end point positions of each bone x1,y1,and x2,y2
    angle = 0

    for i as integer = 1 to 15
        color bones(i).c
        if bones(i).r = 1 then angle = 0:print
        if bones(i).a < 0   then bones(i).a = bones(i).a + 360
        if bones(i).a > 359 then bones(i).a = bones(i).a - 360
        angle = angle + bones(i).a
        bones(i).a2 = angle               'save computed angles for images
        if angle < 0   then angle = angle + 360
        if angle > 359 then angle = angle - 360
        bones(i).x1 = bones( bones(i).p ).x2
        bones(i).y1 = bones( bones(i).p ).y2
        bones(i).x2 = bones(i).x1 + cos(angle*DtoR) * bones(i).s * mag
        bones(i).y2 = bones(i).y1 + sin(angle*DtoR) * bones(i).s * mag
    next i
   
    'draw the bones
    dim as integer ii
    for i as integer = 1 to 15
        'line (bones(i).x1,bones(i).y1)-(bones(i).x2,bones(i).y2),bones(i).c
        'drawLine (bones(i).x1,bones(i).y1,bones(i).x2,bones(i).y2,2,bones(i).c)
        'circle (bones(i).x1,bones(i).y1),3,rgb(200,200,200)
        ii = order(i)
        multiput 0,bones(ii).x1,bones(ii).y1,bones(ii).img,mag,mag,bones(ii).a2,1
    next i
   
    'show selected pivot
    for i as integer = 1 to 15
        if selected = i then
            circle (bones(i).x1,bones(i).y1),8,rgb(255,255,0),,,,f
            draw string (bones(i).x1-6,bones(i).y1-4), str(selected),rgb(0,0,0)
        end if
    next i
   
   
    screenunlock
end sub

dim as string key
dim as integer mx,my,mb

drawBones()
dim as single dd,dx,dy
do

        'enable to click select front most pivot
        getmouse mx,my,,mb
        if mb = 1 then
            for i as integer = 0 to 15
                dx = mx-bones(i).x1
                dy = my-bones(i).y1
                dd = sqr(dx^2+dy^2)
                if dd < 5 then
                    selected = i
                end if
            next i
        end if
       
        'Use key to rotate selected pivot
        key = inkey
        'can use the left/right arrow keys
        If key=Chr(255) +"K" Then bones(selected).a = bones(selected).a - 1
        If key=Chr(255) +"M" Then bones(selected).a = bones(selected).a + 1
        'or can sue the [A] and [D] key
        If key= "a" Then bones(selected).a = bones(selected).a - 1
        If key= "d" Then bones(selected).a = bones(selected).a + 1
       
        'Tap space bar to move selection to next pivot number
        if key = " " then selected = selected + 1
        if selected = 16 then selected = 1
       
        drawBones()
       
        circle (320,240),15,rgb(255,255,0)  'ABSOLUTE START COORD
       
    sleep 2
loop until  multikey(&H01)

'release bitmap memory
imagedestroy(head)
imagedestroy(kneck)
imagedestroy(upperArmLeft)
imagedestroy(lowerArmLeft)
imagedestroy(leftHand)
imagedestroy(upperArmRight)
imagedestroy(lowerArmRight)
imagedestroy(rightHand)
imagedestroy(torso)
imagedestroy(upperLegLeft)
imagedestroy(lowerLegLeft)
imagedestroy(leftShoe)
imagedestroy(upperLegRight)
imagedestroy(lowerLegRight)
imagedestroy(rightShoe)

sleep

'order in which to draw bones for overlap
data 1,2,3,8,9,10,7,4,5,6,11,12,13,14,15
Last edited by BasicCoder2 on Mar 18, 2018 23:43, edited 3 times in total.
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Clothe 2D stick figure

Postby BasicCoder2 » Mar 18, 2018 8:13

viewtopic.php?f=14&t=24105&hilit=FBImage

I replaced the load bitmaps with D.J.Peters FBImage.bi commands to make use of the .png versions but although the program ran it only displayed the head, kneck and torso.

Code: Select all


#include once "FBImage.bi"

...

screenres 640,480,32
'color rgb(0,0,0),rgb(255,255,255):cls

'CREATE AND LOAD IMAGES

'USING https://www.freebasic.net/forum/viewtopic.php?f=14&t=24105&hilit=FBImage
var head = LoadRGBAFile("head.png")
var kneck = LoadRGBAFile("kneck.png")
var upperArmLeft = LoadRGBAFile("upperArmLeft.png")
var lowerArmLeft = LoadRGBAFile("lowerArmLeft.png")
var leftHand = LoadRGBAFile("leftHand.png")
var upperArmRight = LoadRGBAFile("upperArmRight.png")
var lowerArmRight = LoadRGBAFile("lowerArmRight.png")
var rightHand = LoadRGBAFile("rightHand.png")
var torso = LoadRGBAFile("torso.png")
var upperLegLeft = LoadRGBAFile("upperLegLeft.png")
var lowerLegLeft = LoadRGBAFile("lowerLegLeft.png")
var leftShoe = LoadRGBAFile("leftShoe.png")
var upperLegRight = LoadRGBAFile("upperLegRight.png")
var lowerLegRight = LoadRGBAFile("lowerLegRight.png")
var rightShoe = LoadRGBAFile("rightShoe.png")


dim shared as integer selected   'selected bone number
 ...

Last edited by BasicCoder2 on Mar 18, 2018 23:43, edited 1 time in total.
dodicat
Posts: 6692
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Cloth 2D stick figure

Postby dodicat » Mar 18, 2018 10:41

basiccoder2
From the topic infinite image zoom, here is a picture loading routine (Windows only)
It will load various formats including bmp to the screen or an image.
I have a direct pixel method also which is much faster, if speed is important.

Code: Select all


#if sizeof(integer)=8
#include "windows.bi"
#endif
#Include  "win/gdiplus.bi"

Function Pload(Picture as String,byref i as any ptr=0) as long
   Dim As uinteger TMP
   GDIPLUS.GdiplusStartup(@TMP,@type<GDIPLUS.GDIPLUSSTARTUPINPUT>(1),0)
   Dim as any Ptr Img
   if GDIPLUS.GdipLoadImageFromFile(Picture,@Img)>0 then return 0
   Dim As Single w,h
   GDIPLUS.GdipGetImageDimension(Img,@w,@h)
   if w*h=0 then return 0
   Dim As GDIPLUS.BitmapData Pdata
   Dim As Rect R=Type(0,0,w-1,h-1)
   GDIPLUS.GdipBitmapLockBits(Img,Cast(Any Ptr,@R),GDIPLUS.ImageLockModeRead,PixelFormat32bppARGB,@Pdata)
   For y as long = 0 To h-1
      For x as long = 0 To w-1
           pset i,(x,y),Cast(ulong Ptr,Pdata.Scan0)[y*w+x]
      Next
   Next
return w*h
End Function

sub getsize(picture as string,byref w as single,byref h as single)
    Dim As uinteger TMP
   GDIPLUS.GdiplusStartup(@TMP,@type<GDIPLUS.GDIPLUSSTARTUPINPUT>(1),0)
   Dim as any Ptr Img
   if GDIPLUS.GdipLoadImageFromFile(Picture,@Img)>0 then exit sub
   GDIPLUS.GdipGetImageDimension(Img,@w,@h)
end sub
'====================

screen 20,32

dim as string picture="arkadia0.jpg"
if pload(picture)=0 then print picture + "  not found":sleep :end


sleep
 
BasicCoder2
Posts: 3586
Joined: Jan 01, 2009 7:03
Location: Australia

Re: Clothe 2D stick figure

Postby BasicCoder2 » Mar 19, 2018 19:22

dodicat wrote:basiccoder2
From the topic infinite image zoom, here is a picture loading routine (Windows only)
It will load various formats including bmp to the screen or an image.
I have a direct pixel method also which is much faster, if speed is important.

Thanks dodicat.
As for "Windows only" I like the idea of any FB code also running on Linux particularly as I hope to get my new toy, a Raspberry Pi, up and running.
Not sure if I will do anything more with the program. I was just motivated to add clothes to the side view stick man example I posted some time back after Boromir posting images of his nice skeletal sprite tool for animated sprites and wanted to give it a try.
I also posted one of a isometric walking stick man but couldn't figure out how to clothe it. I had thought using the cloud of pixels you are so good at and where pixel drawing speed really makes a difference but never got around to it.

isometric stickman

Code: Select all

'some useful defines
Const Pi = 4 * Atn(1)
Dim Shared As Double TwoPi = 8 * Atn(1)
Dim Shared As Double RtoD = 180 / Pi   ' radians * RtoD = degrees
Dim Shared As Double DtoR = Pi / 180   ' degrees * DtoR = radians

screenres 940,480,32

sub setXYZ(x as double,y as double,z as double)
    circle (x+z\2,y-z\2),3,rgb(0,255,0)
    'draw string (x+z\2,y-z\2),str(int(x+.5))+","+str(int(y+.5))+","+str(int(z+.5))
end sub

sub lineXYZ(x1 as double,y1 as double,z1 as double,x2 as double,y2 as double,z2 as double)
    line (x1+z1\2,y1-z1\2)-(x2+z2\2,y2-z2\2),rgb(255,0,0)
    setXYZ(x1,y1,z1)
    setXYZ(x2,y2,z2)
end sub

type ALINE
    as integer x1
    as integer y1
    as integer z1
    as integer x2
    as integer y2
    as integer z2
end type

dim shared as ALINE lines(1 to 15)

dim shared as integer x1,y1,z1,x2,y2,z2
for i as integer = 1 to 15   'draw 15 lines
    read lines(i).x1,lines(i).y1,lines(i).z1,lines(i).x2,lines(i).y2,lines(i).z2
    lineXYZ(x1,y1,z1,x2,y2,z2)
next i

sub drawLines()
    screenlock
    cls
    for i as integer = 1 to 15   'draw 15 lines
        lineXYZ(lines(i).x1,lines(i).y1,lines(i).z1,lines(i).x2,lines(i).y2,lines(i).z2)
    next i
    screenunlock
end sub

sub rotatePointsY()
    dim as double px1,py1,pz1,px2,py2,pz2,rx1,ry1,rz1,rx2,ry2,rz2
    for angle as double = 0 to 360
        cls
        for i as integer = 1 to 15  '15 lines
            pz1 = lines(i).z1 - 50
            px1 = lines(i).x1 - 350
            py1 = lines(i).y1 - 350
            rz1 = (Cos(angle*DtoR) * pz1 - Sin(angle*DtoR) * px1)+50
            rx1 = (Sin(angle*DtoR) * pz1 + Cos(angle*DtoR) * px1)+350
            ry1 = py1+340
            pz2 = lines(i).z2 - 50
            px2 = lines(i).x2 - 350
            py2 = lines(i).y2 - 350
            rz2 = (Cos(angle*DtoR) * pz2 - Sin(angle*DtoR) * px2)+50
            rx2 = (Sin(angle*DtoR) * pz2 + Cos(angle*DtoR) * px2)+350
            ry2 = py2+340
            LINEXYZ(rx1,ry1,rz1,rx2,ry2,rz2)
        next i
        sleep 50
    next angle
end sub

rotatePointsY()

'drawLines()


sleep


data 321,140,-20,321,140,+20  'shoulder

data 321,140,-20,288,213,-20  'left arm top
data 288,213,-20,280,280,-20  'lower
data 280,280,-20,306,270,-20  'wrist

data 321,140,+20, 334,218,+20 'right arm
data 334,218,+20, 402,237,+20
data 402,237,+20, 428,222,+20

data 322,239,-20, 322,239,+20 'hip

data 322,239,-20, 338,338,-20  'left leg
data 338,338,-20, 268,411,-20
data 268,411,-20, 297,419,-20

data 322,239,+20, 373,326,+20
data 373,326,+20, 337,419,+20
data 337,419,+20, 367,414,+20

data 321,140,0, 322,239,0    'torso

nimdays
Posts: 236
Joined: May 29, 2014 22:01
Location: ID

Re: Clothe 2D stick figure

Postby nimdays » Mar 22, 2018 22:38

BasicCoder2 wrote:Are they blocked in Indonesia?

No, I can see that.Thanks again.
D.J.Peters
Posts: 8180
Joined: May 28, 2005 3:28
Contact:

Re: Clothe 2D stick figure

Postby D.J.Peters » Mar 23, 2018 1:03

Your links was wrong
you can save as ... via right click now

Joshy
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image
Image

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest