微信公众号搜"智元新知"关注
微信扫一扫可直接关注哦！

Perl 闭包模拟类实现二叉树

分类：Perl作者：编程之家AI导航网

在上一篇文章中用函数方式实现了一个二叉树，本篇用闭包模拟类的方式来重新实现，不同于传统意义的Perl 类，否则也不用去费力重新实现，本篇用闭包来模拟类的一些行为，以消息传递的方式调用方法。


功能同上一个版本的基本一样，是用闭包的好处：

1。 模拟类行为，开放类方法

2。 内部变量不可直接修改，只能通过方法调用获取或修改值

3。 消息类型多样，自己可以随便控制


特点：

1。 每次取得一个节点（增加，删除，修改）都是一个闭包Node 的返回，可以看作对应的类实例，可通过进一步调用来获取相应的值

2。 只有两个模拟类，Node and BNSTree，通篇都是通过这两个闭包类来进行操作


附代码以及编写过程中的一些注释：

use strict;
use warnings;
use Data::Dumper;

sub Node {
    my $_node = { left => undef,right => undef,key => undef,parent => undef };

    # set multiple value at same time
    my %params = @_;
    map { $_node->{$_} = $params{$_} if defined $params{$_} } keys %$_node;

    # set or get value for each item
    return sub {
        my ( $msg,$value ) = @_;
        if ( exists $_node->{$msg} ) {
            defined $value ? $_node->{$msg} = $value : $_node->{$msg};
        }
        # because cannot set one of attribute of _node to undef,so add one method delete to set to undef
        elsif ( $msg eq 'delete' && $value ) {
            $_node->{$value} = undef;
        }
        else {
            die "Undefined key: $msg";
        }
    }
}

sub BNSTree {
    my $root = undef;

    my $empty = sub {
        return !$root;
    };

    #this is original version for insert,logic is clear but code is too much
    my $insert_old = sub {
        my ($value) = @_;
        if ( $empty->() ) {
            my $node = Node( key => $value );
            return $root = $node;
        }

        my $tmp = $root;
        while ( $value != $tmp->('key') ) {
            if ( $value < $tmp->('key') && $tmp->('left') ) {
                $tmp = $tmp->('left');
            }
            elsif ( $value > $tmp->('key') && $tmp->('right') ) {
                $tmp = $tmp->('right');
            }
            else {
                last;
            }
        }

        if ( $value < $tmp->('key') ) {
            my $node = Node( key => $value,parent => $tmp );
            return $tmp->( left => $node );
        }
        elsif ( $value > $tmp->('key') ) {
            my $node = Node( key => $value,parent => $tmp );
            return $tmp->( right => $node );
        }
        else {
            return $tmp;
        }
    };

    #this is optimized version for insert,almost 1/2 less code than prevIoUs and tight
    my $insert = sub {
        my ($value) = @_;
        return $root = Node( key => $value ) if $empty->();

        my $tmp = $root;
        while ( $value != $tmp->('key') ) {
            if ( $value < $tmp->('key') ) {
                $tmp->('left')
                  ? $tmp = $tmp->('left')
                  : return $tmp->( left => Node( key => $value,parent => $tmp ) );
            }
            elsif ( $value > $tmp->('key') ) {
                $tmp->('right')
                  ? $tmp = $tmp->('right')
                  : return $tmp->( right => Node( key => $value,parent => $tmp ) );
            }
            #~ else{ last; }
        }
        return $tmp;
    };

    my $min_max = sub {
        #~ my ($msg) = @_;
        #~ return if $empty->();

        #~ my $tmp = $root;
        #~ while($tmp->($msg)){
        #~ $tmp = $tmp->($msg);
        #~ }
        #~ return $tmp;

        #prevIoUs version work for the whole tree,but successor need it,so modify it that can be used by sub-tree min max
        my ( $msg,$tmp_root ) = @_;
        return if !$tmp_root;

        while ( $tmp_root->($msg) ) {
            $tmp_root = $tmp_root->($msg);
        }
        return $tmp_root;
    };

    my $search = sub {
        my ($value) = @_;
        return if $empty->();

        my $tmp = $root;
        while ( $value != $tmp->('key') ) {
            if ( $value < $tmp->('key') ) {
                $tmp->('left') ? $tmp = $tmp->('left') : return;
            }
            elsif ( $value > $tmp->('key') ) {
                $tmp->('right') ? $tmp = $tmp->('right') : return;
            }
            else { last; }
        }
        return $tmp;
    };

    my $successor = sub {
        my ($value) = @_;

        #~ return undef if $empty->();
        my $search_item = $search->($value);
        return if !$search_item;

        if ( $search_item->('right') ) {
       #~ my $tmp = $search_item->('right');
       #~ while($tmp->('left')){
       #~ $tmp = $tmp->('left');
       #~ }
       #~ return $tmp;
       # prevIoUs version need expend min function,so modify it use subtree min
            return $min_max->( 'left',$search_item->('right') );
        }

        my $tmp = $search_item;
        while ($tmp->('parent')
            && $tmp->('parent')->('right')
            && $tmp->('parent')->('right') == $tmp )
        {
            $tmp = $tmp->('parent');
        }
        return $tmp->('parent');
    };

    my $predecessor = sub {
        my ($value) = @_;

        #~ return undef if $empty->();
        my $search_item = $search->($value);
        return undef if !$search_item;

        if ( $search_item->('left') ) {
       #~ my $tmp = $search_item->('right');
       #~ while($tmp->('left')){
       #~ $tmp = $tmp->('left');
       #~ }
       #~ return $tmp;
       # prevIoUs version need expend min function,so modify it use subtree min
            return $min_max->( 'right',$search_item->('left') );
        }

        my $tmp = $search_item;
        while ($tmp->('parent')
            && $tmp->('parent')->('left')
            && $tmp->('parent')->('left') == $tmp )
        {
            $tmp = $tmp->('parent');
        }
        return $tmp->('parent');
    };

    #go through from upper level to lower level
    my $level_order = sub {
        return if $empty->();

        #~ my $tmp = $root;
        my @stack = ($root);
        while (@stack) {
            my $tmp = shift @stack;
            print $tmp->('key'),' ';
            push @stack,$tmp->('left')  if $tmp->('left');
            push @stack,$tmp->('right') if $tmp->('right');
        }
    };

    my $in_order = sub {
        return if $empty->();

        my $tmp   = $root;
        my @stack = ();
        while ( $tmp || @stack ) {
            if ($tmp) {
                print $tmp->('key'),' ';
                push @stack,$tmp;
                $tmp = $tmp->('left');
            }
            else {
                $tmp = pop @stack;

                #~ print $tmp->('key'),' ';
                $tmp = $tmp->('right');
            }
        }
    };

    my $pre_order = sub {
        return if $empty->();

        my $tmp   = $root;
        my @stack = ();
        while ( $tmp || @stack ) {
            if ($tmp) {
                push @stack,$tmp;
                $tmp = $tmp->('left');
            }
            else {
                $tmp = pop @stack;
                print $tmp->('key'),' ';
                $tmp = $tmp->('right');
            }
        }
    };

    my $suc_order = sub {
        return if $empty->();

        my $tmp   = $root;
        my @stack = ();
        while ( $tmp || @stack ) {
            if ($tmp) {
                push @stack,$tmp;
                $tmp = $tmp->('right');
            }
            else {
                $tmp = pop @stack;
                print $tmp->('key'),' ';
                $tmp = $tmp->('left');
            }
        }
    };

    my $internal_delete = sub {
        my ($node) = @_;

        if ( $node->('parent') ) {
            my $pchild =
              $node->('parent')->('key') > $node->('key') ? 'left' : 'right';
            if ( !$node->('left') && !$node->('right') ) {
                $node->('parent')->( delete => $pchild );
            }
            elsif ( !$node->('left') || !$node->('right') ) {
                my $child = $node->('left') ? 'left' : 'right';

                $node->('parent')->( $pchild => $node->($child) );
                $node->($child)->( parent => $node->('parent') );
            }
        }
        else {
            if ( !$node->('left') && !$node->('right') ) {
                $root = undef;
            }
            elsif ( !$node->('left') || !$node->('right') ) {
                my $child = $node->('left') ? 'left' : 'right';

                $root = $node->($child);
                $node->($child)->( delete => 'parent' );
            }
        }
    };

    my $delete = sub {
        my ($value) = @_;
        my $tmp = $search->($value);

        if ( !$tmp ) {
            return;
        }
        elsif ( !$tmp->('left') || !$tmp->('right') ) {
            $internal_delete->($tmp);
        }
        else {
            my $suc = $successor->($value);
            $internal_delete->($suc);
            $tmp->( 'key',$suc->('key') );
        }
    };

    #initial binary search tree with more values
    for (@_) {
        $insert->($_);
    }

    return sub {
        my ( $msg,$value ) = @_;
        if ( $msg eq 'empty' ) {
            $empty->();
        }
        elsif ( $msg eq 'insert' ) {
            $insert->($value);
        }
        elsif ( $msg eq 'min' ) {
            $min_max->( 'left',$root );
        }
        elsif ( $msg eq 'max' ) {
            $min_max->( 'right',$root );
        }
        elsif ( $msg eq 'search' ) {
            $search->($value);
        }
        elsif ( $msg eq 'successor' ) {
            $successor->($value);
        }
        elsif ( $msg eq 'predecessor' ) {
            $predecessor->($value);
        }
        elsif ( $msg eq 'print' && $value && $value eq 'pre' ) {
            $pre_order->();
        }
        elsif ( $msg eq 'print' && $value && $value eq 'suc' ) {
            $suc_order->();
        }
        elsif ( $msg eq 'print' ) {
            $in_order->();
        }
        elsif ( $msg eq 'delete' ) {
            $delete->($value);
        }
    }
}

my $a = BNSTree(qw(14  20 18 21 7 ));

$a->( 'delete',14 );
$a->( parent => undef );
$a->('print');
print "\n";
$a->( 'print','pre' );
print "\n";
$a->( 'print','suc' );
print "\n";

版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。

相关推荐

Perl碎碎念
1. 如何去重 #!/usr/bin/perl use strict; my %hash; while(&lt;&gt;){ chomp; print &quot;$_n&quot; unless
如何用perl将表格中不同列的数据进行拼凑，然后将拼凑后的数据用“|”连接在一起
最近写了一个perl脚本，实现的功能是将表格中其中两列的数据进行拼凑，然后将拼凑后的数据用“|”连接在一起。表格内容如下： 员工号码员工姓名职位入职日期1001张三销售1980/12/17 0:00:
基于表的数据字典构造MySQL建表语句
表的数据字典格式如下：如果手动写MySQL建表语句，确认麻烦，还不能保证书写一定正确。写了个Perl脚本，可快速构造MySQL脚本语句。脚本如下：#!/usr/bin/perluse strict;m
如何用Perl对Excel的数据进行提取并分析
巡检类工作经常会出具日报，最近在原有日报的基础上又新增了一个表的数据量统计日报，主要是针对数据库中使用较频繁，数据量又较大的31张表。该日报有两个sheet组成，第一个sheet是数据填写，第二个sh
如何用Perl截取报文
在实际生产环境中，常常需要从后台日志中截取报文，报文的形式类似于.........一个后台日志有多个报文，每个报文可由操作流水唯一确定。以前用AWK写过一个，程序如下：beginline=`awk &
如何通过关键词匹配统计其出现的频率
最近写的一个perl程序，通过关键词匹配统计其出现的频率，让人领略到perl正则表达式的强大，程序如下：#!/usr/bin/perluse strict;my (%hash,%hash1,@arra
漫谈 Perl 的 web 应用开发框架
忍不住在 PerlChina 邮件列表中盘点了一下 Perl 里的 Web 应用框架（巧的是 PerlBuzz 最近也有一篇相关的讨论帖），于是乎，决定在我自己的 blog 上也贴一下 :) 原生 CGI/FastCGI 的 web app 对于较小的应用非常合适，但稍复杂一些就有些痛苦，但运行效率是最高的 ;) 如果是自己用 Perl 开发高性能的站，多推荐之。 Catalyst, CGI::A
perl中bless的理解
bless有两个参数：对象的引用、类的名称。 类的名称是一个字符串，代表了类的类型信息，这是理解bless的关键。 所谓bless就是把 类型信息 赋予 实例变量。 程序包括5个文件： person.pm ：实现了person类 dog.pm ：实现了dog类 bless.pl ： 正确的使用bless bless.wrong.pl ： 错误的使用bless bless.cc ： 使用C++语言实
PERL GB2312 UTF-8 编码转换
gb2312转Utf的方法： use Encode; my $str = "中文"; $str_cnsoftware = encode("utf-8", decode("gb2312", $str));   Utf转 gb2312的方法： use Encode; my $str = "utf8中文"; $str_cnsoftware = encode("gb2312", decode("utf-8
perl 计算硬盘利用率
  perl 计算硬盘利用率， 以%来查看硬盘资源是否存在IO消耗cpu资源情况； 部份代码参考了iostat源码；     #!/usr/bin/perl use Time::HiRes qw(gettimeofday); use POSIX; $SLEEPTIME=3; sub getDiskUtl() { $clock_ticks = POSIX::sysconf( &POSIX::_SC_
苹果市值2025年有望达4万亿美元
pythonJavaScriptjavaHTMLreactjsC#AndroidCSSNode.jssqlrpython-3.xMysqLjQueryc++pandasFlutterangularIOSdjangolinuxswifttypescript路由器JSON路由器设置无线路由器h3c华三华三路由器设置华三路由器电脑软件教程arraysdocker软件图文教程Cvue.jslaravelspring-bootreact-native